VBA 替代 OFFSET/INDIRECT？

Question

我正在使用 OFFSET/INDIRECT 从多个工作簿中提取数组。它们的格式彼此相似，因此我想对所有格式使用一个公式，即“偏移/间接”。

这是我到目前为止 A2 中的内容：

=OFFSET(INDIRECT("'"&A1&"'!$A$1"),MATCH("Total",INDIRECT("'"&A1&"'!$A:$A"),0),0,2,3)

A1 是源工作簿的名称 - 例如：My Workbook.xlsx。然后在 A4 中我有不同源工作簿的名称，只需将公式复制到 A5 即可：

=OFFSET(INDIRECT("'"&A4&"'!$A$1"),MATCH("Total",INDIRECT("'"&A4&"'!$A:$A"),0),0,2,3)

等等。但是，我可能有 50 个工作簿需要从中提取数据，并且每当我需要查看数据时都打开所有 50 个工作簿并不理想。我尝试制作一个简单的宏来一次打开所有 50 个工作簿，但最终我仍然不得不关闭它们，这很乏味。

我尝试使用这里和这里的VBA解决方案。新公式如下所示：

=OFFSET(INDIRECTVBA("'"&A1&"'!$A$1"),MATCH("Total",INDIRECTVBA("'"&A1&"'!$A:$A"),0),0,2,3)

我得到了#VALUE！错误。我该如何解决？这是 VBA 中的内容：

Public Function INDIRECTVBA(ref_text As String)
    INDIRECTVBA = Application.ThisCell.Parent.Range(ref_text)
End Function

Public Sub FullCalc()
    Application.CalculateFull
End Sub

我知道即使我解决了这个问题，我仍然有 OFFSET 功能，这也需要打开源工作簿。这种不需要我打开所有资料书的“偏移/间接”设置的替代方案是什么？

如果有任何困惑，请告诉我。

Answer 1

工作表更改：Excel

INDIRECT

VBA 替代方案

• 所有源文件需要位于同一文件夹中，并且其相关工作表需要具有相同的名称！

• 当在单元格

  A1, A4, A7,... etc.

  中输入数据（源工作簿名称）时，以及当源工作簿。
• 如果源工作簿被删除，即无法找到它，则通过手动运行子程序或下次打开目标工作簿时，目标工作表将被更新（检索到的值将被清除）。

工作表模块

Sheet1

• 将工作簿保存为启用宏，即

  .xlsm

  (

  .xlsb

  )。
• 在 Excel 中，选择目标工作表。右键单击其选项卡并选择

  View Code

  。
• 进入打开的窗口（工作表模块），复制以下代码。

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    UpdateFromClosedWorkbooks Target
End Sub

• 记住窗口标题栏右侧工作表的代码名称。在屏幕截图中，它是

  Sheet1

  但在您的情况下可能会有所不同。

ThisWorkbook

模块

• 如果尚未打开，请打开View-->Project Explorer。选择您的（正确的）工作簿（可以是更开放的工作簿）。
• 双击

  ThisWorkbook

  。

• 注意屏幕截图中记忆的工作表代码名称，即不在括号中的代码名称 (

  Sheet1

  )。
• 在打开的窗口（

  ThisWorkbook

  模块）中，粘贴以下代码。

Option Explicit

Private Sub Workbook_Open()
    UpdateFromClosedWorkbooks
End Sub

• 窗口的标题栏显示您是否打开了正确的窗口（模块）。

标准模块

Module1

• 在 Project Explorer 中右键单击工作簿的任意项目，然后选择

  Insert Module

  。
• 在打开的窗口（标准模块）中，粘贴以下代码。

Option Explicit

Sub UpdateFromClosedWorkbooks(Optional ByVal Target As Variant)
    On Error GoTo ClearError
    
    ' Source (Closed Workbook)
    Const SRC_FOLDER_PATH As String = "C:\Test" ' *****
    Const SRC_SHEET_NAME As String = "Sheet1" ' *****
    Const SRC_SEARCH_STRING As String = "Total"
    Const SRC_COLUMN As String = "A"
    Const SRC_ROW_OFFSET As Long = 1
    Const SRC_COLUMN_OFFSET As Long = 0
    ' Both (the numbers from your formula)
    Const ROWS_COUNT As Long = 2
    Const COLUMNS_COUNT As Long = 3
    ' Destination (Workbook Containing This Code)
    Const DST_FIRST_CELL As String = "A1"
    Const DST_ROW_OFFSET As Long = 1
    Const DST_ROWS_GAP As Long = 0
    Const DST_COLUMN_OFFSET As Long = 0
    
    Dim dws As Worksheet
    If IsMissing(Target) Then '  for 'Workbook_Open'
        Set dws = Sheet1 ' the sheet's code name ' *****
    Else ' for 'Worksheet_Change'
        Set dws = Target.Worksheet
    End If
    
    Dim dcrg As Range, drCount As Long
    
    With dws.Range(DST_FIRST_CELL)
        drCount = dws.Cells(dws.Rows.Count, .Column).End(xlUp).Row - .Row + 1
        If drCount < 1 Then Exit Sub
        Set dcrg = .Resize(drCount)
    End With
        
    Dim drOffset As Long: drOffset = ROWS_COUNT + DST_ROWS_GAP + 1
        
    Dim durg As Range, irg As Range, r As Long
    
    For r = 1 To drCount Step drOffset
        If durg Is Nothing Then
            Set durg = dcrg.Cells(r)
        Else
            Set durg = Union(durg, dcrg.Cells(r))
        End If
    Next r
     
    If IsMissing(Target) Then ' for 'Workbook_Open'
        Set irg = durg
    Else ' for 'Worksheet_Change'
        Set irg = Intersect(durg, Target)
        If irg Is Nothing Then Exit Sub
    End If
    
    Dim drg As Range, dcell As Range, icell As Range
    Dim sName As String, sPath As String, sSheet As String, sAddress As String
        
    Application.EnableEvents = False
    
    For Each icell In irg.Cells
        sName = icell.Value
        Set dcell = icell.Offset(DST_ROW_OFFSET, DST_COLUMN_OFFSET)
        Set drg = dcell.Resize(ROWS_COUNT, COLUMNS_COUNT)
        sPath = SRC_FOLDER_PATH & "\" & sName
        If Len(Dir(sPath)) = 0 Then
            drg.ClearContents
        Else
            sSheet = "'" & SRC_FOLDER_PATH & "\[" & sName & "]" _
                & SRC_SHEET_NAME & "'!"
            dcell.Formula = "=MATCH(""" & SRC_SEARCH_STRING & """," & sSheet _
                & SRC_COLUMN & ":" & SRC_COLUMN & ",0)"
            'dcell.Calculate
            If IsNumeric(dcell.Value) Then
                sAddress = dws.Cells(dcell.Value, SRC_COLUMN) _
                    .Offset(SRC_ROW_OFFSET, SRC_COLUMN_OFFSET).Address(0, 0)
                drg.Formula = "=" & sSheet & sAddress
            End If
        End If
    Next icell
 
ProcExit:
    On Error Resume Next
        Application.EnableEvents = True
    On Error GoTo 0
    Exit Sub
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical
    Resume ProcExit
End Sub

• 窗口的标题栏显示您是否打开了正确的窗口（模块）。
• 在这段冗长的代码中，找到行

  Set dws = Sheet1 ' the sheet's code name ' *****

  并将

  Sheet1

  替换为记住的工作表代码名称（请注意，没有引号）。
• 此外，在代码开头的“常量部分”（参见屏幕截图底部），调整源文件的路径和工作表名称。