VBA跨工作簿引用源数据出现下标越界错误的解决方法

我有一个名为Dashboard的仪表盘工作表，其中配置了多组数据透视表，这些数据透视表依赖同工作簿内Dashboard_Data工作表存储的动态数据集。原有宏的运行逻辑如下：

• 提示用户选择原始数据所在工作表的任意单元格，适配原始数据表名不固定的场景
• 宏自动提取所需数据整合到Dashboard_Data工作表
• 最后刷新所有数据透视表
  当原始数据存储在当前工作簿的工作表中时，该逻辑可正常运行。

现在需要改造宏，支持用户选择其他工作簿内存储的原始数据，但直接运行现有代码时会触发subscript out of range（下标越界）错误。目前已编写测试代码尝试通过GetOpenFilename方法获取外部数据源工作簿的路径，但不知道如何正确配置Worksheet对象的引用路径，为Ws变量正确赋值指向外部工作簿的目标工作表以避免下标越界错误，现有问题代码如下：

Option Explicit
Sub HB_Run_Dashboard()

Dim Ws As Worksheet, lastRow As Long
Dim myNamedRange As Range, Rng As Range, c As Range, destrange As Range
Dim myRangeName As String
Dim desiredSheetName As String
Dim SearchRow As Long
Dim StartatRow As Long
Dim pvt As PivotTable
Dim S As String

'user prompt to locate cell in the sheet with the raw data to capture sheet name
desiredSheetName = Application.InputBox("Select any cell inside the source sheet: ", _
"Prompt for selecting target sheet name", Type:=8).Worksheet.Name

'currently a test code to also have the user find the location of the sheet
'Inputsheetpath = Application.GetOpenFilename(FileFilter:= _
"Excel Workbooks (*.xls*),*.xls*,*.xlsb,*.xlsm", Title:="Open Database File")

'this is where i am stuck. how to set the WS with the correct path info to avoid subscript out of range
Set Ws = Workbook.Worksheets(desiredSheetName)

SearchRow = InputBox("Row # where Reference 'Dashboard' is entered.", "Row Input")
StartatRow = InputBox("Row # where Headers are located.", "Row Input")

'Const SearchRow As Long = SRow
'Const StartAtRow As Long = StRow
Const RangeName As String = "Dashboard_Data_Raw"

lastRow = Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row

'loop cells in row to search...
For Each c In Ws.Range(Ws.Cells(SearchRow, 1), _
                       Ws.Cells(SearchRow, Columns.Count).End(xlToLeft)).Cells
    If LCase(c.Value) = "dashboard" Then 'want this column
        'add to range
        BuildRange myNamedRange, _
            Ws.Range(Ws.Cells(StartatRow, c.Column), Ws.Cells(lastRow, c.Column))
       
    End If
Next c

Debug.Print myNamedRange.Address
Worksheets(desiredSheetName).Names.Add Name:=RangeName, RefersTo:=myNamedRange

下标越界的核心原因有3个：

1. GetOpenFilename方法仅能获取选中文件的路径字符串，不会自动打开目标文件，VBA无法直接访问未打开工作簿内的工作表对象
2. 代码中Set Ws = Workbook.Worksheets(desiredSheetName)没有指定具体的工作簿对象，默认只会在当前运行宏的工作簿中查找工作表，外部工作簿的工作表自然找不到
3. 原有的Application.InputBox(Type:=8)选单元格逻辑，仅支持选择当前已打开工作簿内的单元格，未打开的外部工作簿单元格无法被直接选中

调整执行顺序：先让用户选择外部数据源文件→后台打开该文件→让用户在已打开的数据源文件中选择目标工作表的单元格→正确绑定工作簿、工作表对象，修复后的完整代码如下：

Option Explicit
Sub HB_Run_Dashboard()
    Dim Ws As Worksheet, lastRow As Long
    Dim myNamedRange As Range, c As Range
    Dim desiredSheetName As String
    Dim SearchRow As Long, StartatRow As Long
    Dim Inputsheetpath As Variant
    Dim wbSource As Workbook, wbCurrent As Workbook
    Const RangeName As String = "Dashboard_Data_Raw"
    
    ' 关闭屏幕闪屏提升运行速度
    Application.ScreenUpdating = False
    Set wbCurrent = ThisWorkbook ' 绑定当前运行宏的工作簿
    
    ' 1. 让用户选择外部数据源文件
    Inputsheetpath = Application.GetOpenFilename(FileFilter:= _
        "Excel Workbooks (*.xls*),*.xls*,*.xlsb,*.xlsm", Title:="选择原始数据文件")
    ' 用户点取消的话直接退出过程
    If Inputsheetpath = False Then
        Application.ScreenUpdating = True
        Exit Sub
    End If
    
    ' 2. 后台打开选中的数据源工作簿，绑定到wbSource变量
    Set wbSource = Workbooks.Open(Filename:=Inputsheetpath, ReadOnly:=True)
    
    ' 3. 让用户在打开的数据源工作簿里选目标工作表的任意单元格
    On Error Resume Next ' 捕获用户点取消的错误
    desiredSheetName = Application.InputBox("选择源数据表内任意单元格: ", _
        "选择目标工作表", Type:=8).Worksheet.Name
    If Err.Number <> 0 Then
        wbSource.Close SaveChanges:=False
        Application.ScreenUpdating = True
        Exit Sub
    End If
    On Error GoTo 0
    
    ' 4. 正确给Ws变量赋值，明确指定是数据源工作簿里的工作表
    Set Ws = wbSource.Worksheets(desiredSheetName)
    
    ' 后续参数输入逻辑
    SearchRow = InputBox("输入标注'Dashboard'所在的行号：", "行号输入")
    StartatRow = InputBox("输入表头所在的行号：", "行号输入")
    
    lastRow = Ws.Cells(Ws.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历查找目标列
    For Each c In Ws.Range(Ws.Cells(SearchRow, 1), _
                           Ws.Cells(SearchRow, Ws.Columns.Count).End(xlToLeft)).Cells
        If LCase(c.Value) = "dashboard" Then
            BuildRange myNamedRange, _
                Ws.Range(Ws.Cells(StartatRow, c.Column), Ws.Cells(lastRow, c.Column))
        End If
    Next c
    
    ' 注意：不要在外部源工作簿建名称，源文件关闭后名称会失效
    ' 直接把myNamedRange的数据读取到当前工作簿的Dashboard_Data表即可
    Debug.Print myNamedRange.Address
    
    ' 用完关闭外部数据源工作簿，不保存更改
    wbSource.Close SaveChanges:=False
    Application.ScreenUpdating = True
    
    ' 后续原有数据整合、刷新透视表逻辑放在这里
End Sub

' 原有BuildRange辅助过程保持不变
Sub BuildRange(ByRef unionRng As Range, addRng As Range)
    If unionRng Is Nothing Then
        Set unionRng = addRng
    Else
        Set unionRng = Union(unionRng, addRng)
    End If
End Sub

• 不要在外部数据源工作簿中创建命名范围，外部文件关闭后该命名范围会失效，直接将读取到的myNamedRange数据复制到当前工作簿的Dashboard_Data工作表即可
• 打开外部工作簿时设置ReadOnly:=True可以避免误改源数据，关闭时设置SaveChanges:=False不会弹出保存提示
• 全程用绑定的工作簿、工作表对象操作，不要用ActiveWorkbook、ActiveSheet这类不稳定的引用，避免用户切换窗口导致对象指向错误

内容的提问来源于stack exchange，提问作者H BG