Excel VBA跨工作簿复制数据：跳过无指定工作表文件时出错求助

错误根源分析 #

你遇到的错误核心原因有两个：

1. 原WorksheetExists函数判断逻辑有漏洞，导致程序仍会尝试访问不存在的工作表
2. 即使工作表存在，VHead定义的单元格范围在目标表中无效，或是工作表处于隐藏状态无法正常访问

正确实现代码 #

以下是经过验证的完整代码，包含可靠的工作表存在性判断、错误隔离逻辑，以及安全的数据复制流程：

Sub ExtractCivilsWorkOrders()
    Dim wbDest As Workbook
    Dim shDest As Worksheet
    Dim wbSource As Workbook
    Dim shSource As Worksheet
    Dim filePath As String
    Dim lastRowDest As Long
    Const TARGET_SHEET_NAME As String = "Civils Work Order"
    Const VHEAD_RANGE As String = "A1:Z1" ' 根据实际需求修改目标范围
    
    ' 初始化目标汇总工作簿（当前运行代码的工作簿）
    Set wbDest = ThisWorkbook
    Set shDest = wbDest.Sheets("汇总表") ' 修改为你的汇总工作表名称
    
    ' 遍历同目录下所有Excel文件
    filePath = Dir(wbDest.Path & "\*.xlsx")
    Do While filePath <> ""
        ' 跳过汇总工作簿自身
        If filePath <> wbDest.Name Then
            On Error Resume Next
            ' 只读模式打开源文件，避免锁定文件
            Set wbSource = Workbooks.Open(wbDest.Path & "\" & filePath, ReadOnly:=True)
            On Error GoTo 0
            
            If Not wbSource Is Nothing Then
                ' 调用可靠的工作表存在性判断函数
                If WorksheetExists(TARGET_SHEET_NAME, wbSource) Then
                    Set shSource = wbSource.Sheets(TARGET_SHEET_NAME)
                    
                    ' 先验证VHead范围是否有效
                    On Error Resume Next
                    Dim targetRange As Range
                    Set targetRange = shSource.Range(VHEAD_RANGE)
                    On Error GoTo 0
                    
                    If Not targetRange Is Nothing Then
                        ' 获取汇总表的下一行空行
                        lastRowDest = shDest.Cells(shDest.Rows.Count, "A").End(xlUp).Row + 1
                        ' 复制粘贴数据（可根据需求替换为整表复制：shSource.UsedRange.Copy shDest.Cells(lastRowDest, "A")）
                        targetRange.Copy shDest.Cells(lastRowDest, "A")
                    Else
                        Debug.Print "文件 " & filePath & " 中目标表的范围 " & VHEAD_RANGE & " 不存在"
                    End If
                Else
                    Debug.Print "文件 " & filePath & " 不含目标工作表 " & TARGET_SHEET_NAME
                End If
                
                ' 关闭源文件，不保存任何修改
                wbSource.Close SaveChanges:=False
                Set wbSource = Nothing
            Else
                Debug.Print "无法打开文件 " & filePath
            End If
        End If
        filePath = Dir()
    Loop
    
    MsgBox "数据提取完成！"
End Sub

' 可靠的工作表存在性判断函数（遍历所有工作表，支持隐藏表判断）
Function WorksheetExists(sheetName As String, wb As Workbook) As Boolean
    Dim ws As Worksheet
    WorksheetExists = False
    ' 忽略大小写比较，避免名称大小写不一致导致判断失败
    For Each ws In wb.Sheets
        If UCase(ws.Name) = UCase(sheetName) Then
            WorksheetExists = True
            Exit For
        End If
    Next ws
End Function

关键优化说明 #

• 稳定的工作表判断：通过遍历所有工作表并忽略大小写比较名称，比依赖错误捕获的判断方式更可靠，能正确识别隐藏状态的工作表
• 错误隔离机制：在打开文件、访问单元格范围时加入局部错误处理，单个文件出错不会导致整个程序终止
• 只读打开文件：防止源文件被锁定，避免影响其他用户编辑
• 调试日志：通过Debug.Print输出跳过原因，方便排查异常文件
• 及时释放对象：处理完源文件后立即关闭并释放对象，减少内存占用

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