VBA跨工作簿粘贴触发Subscript Out of Range错误求助

错误根源 #

触发「Subscript Out of Range」错误的核心原因如下：

• 工作簿名称引用错误：保存的文件是DataFiles.xlsx，但代码中用Workbooks("DataFiles")调用，缺少扩展名，导致无法定位目标工作簿
• 依赖Activate/Select操作：频繁切换激活窗口容易引发上下文混乱，导致对象引用失效
• 未声明变量：TargetRowSTD未定义就直接使用，会触发编译错误
• 取消文件选择后未终止流程：用户取消选择文件时，代码仍会继续执行后续逻辑

修正后的代码 #

Sub CombineAndCopyData()
    ' 声明所有变量
    Dim xFilesToOpen As Variant
    Dim I As Integer
    Dim xWb As Workbook
    Dim xTempWb As Workbook
    Dim TargetFileName As String
    Dim TargetFilePath As String
    Dim ws As Worksheet
    Dim TargetRow As Long
    Dim TargetRowName As Long
    Dim TargetRowSTD As Long ' 补充声明变量
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False ' 关闭保存提示
    
    ' 选择要合并的文件
    xFilesToOpen = Application.GetOpenFilename("Excel Files (*.xlsx;*.xls), *.xlsx;*.xls", , "Select Files", , True)
    If TypeName(xFilesToOpen) = "Boolean" Then
        MsgBox "No files were selected", , "Select Files"
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Exit Sub ' 用户取消选择后直接终止
    End If
    
    ' 合并文件到新工作簿
    Set xTempWb = Workbooks.Open(xFilesToOpen(1))
    xTempWb.Sheets(1).Copy
    Set xWb = Application.ActiveWorkbook
    xTempWb.Close False
    
    For I = 2 To UBound(xFilesToOpen)
        Set xTempWb = Workbooks.Open(xFilesToOpen(I))
        xTempWb.Sheets(1).Move After:=xWb.Sheets(xWb.Sheets.Count)
        xTempWb.Close False
    Next I
    
    ' 保存合并后的工作簿
    TargetFileName = "DataFiles"
    TargetFilePath = "C:\Users\CorToTheWin\Documents\Do Not Delete\" & TargetFileName & ".xlsx"
    xWb.SaveAs Filename:=TargetFilePath
    
    ' 初始化目标行
    TargetRow = 5
    TargetRowName = 4
    TargetRowSTD = 5 ' 初始化变量，根据实际需求调整
    
    ' 直接通过对象引用操作，避免Activate/Select
    Dim targetWb As Workbook
    On Error Resume Next
    Set targetWb = Workbooks("DataProcessing.xlsm")
    On Error GoTo 0
    If targetWb Is Nothing Then
        MsgBox "DataProcessing.xlsm未打开，请先打开该文件", vbExclamation
        xWb.Close False
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Exit Sub
    End If
    
    ' 循环复制数据
    For Each ws In xWb.Worksheets
        ' 复制B16到A列对应行
        targetWb.Sheets(1).Range("A" & TargetRowName).Value = ws.Range("B16").Value
        
        ' 复制C17:C26到B列对应行
        targetWb.Sheets(1).Range("B" & TargetRow).Resize(10, 1).Value = ws.Range("C17:C26").Value
        
        ' 复制E17:E26到C列对应行
        targetWb.Sheets(1).Range("C" & TargetRow).Resize(10, 1).Value = ws.Range("E17:E26").Value
        
        ' 复制D17:D26到D列对应行
        targetWb.Sheets(1).Range("D" & TargetRow).Resize(10, 1).Value = ws.Range("D17:D26").Value
        
        ' 下移目标行
        TargetRow = TargetRow + 12
        TargetRowName = TargetRowName + 12
        TargetRowSTD = TargetRowSTD + 12
    Next ws
    
    ' 清理资源
    xWb.Close SaveChanges:=False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

关键优化点 #

• 用对象变量替代名称引用：全程使用xWb（合并后的工作簿）和targetWb（目标工作簿）直接操作，避免因名称/扩展名问题找不到对象
• 移除Activate/Select：直接通过单元格对象赋值，既提升效率又避免上下文错误
• 补充变量声明：修复TargetRowSTD未声明的问题
• 增加错误判断：检查目标工作簿是否打开，避免后续操作失败
• 优化循环逻辑：将Do While改为For循环，代码更简洁
• 关闭不必要的提示：减少弹窗干扰，提升运行流畅度

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