Excel VBA运行时错误1004：遍历目录文件复制表格时触发报错

核心问题 #

1004错误由代码中的不稳定写法触发，具体问题如下：

• 操作Range对象时没有明确绑定所属的工作簿和工作表，直接写Range("A1")默认指向代码所在的工作簿的激活工作表，而非你刚打开的目标文件，状态不匹配时就会触发对象定义错误
• 使用Select、Selection这类依赖窗口激活状态的写法，在关闭屏幕更新的场景下极易出现状态异常
• 没有判断表格数据边界就使用xlToRight、xlDown，如果A1为空或者只有单行/单列数据，会选中全表空单元格，触发资源溢出类错误
• 额外问题：原代码复制内容后没有粘贴目标，执行完不会保留任何复制结果，且设置了SaveChanges:=True可能意外修改原文件

修复后代码 #

Sub LoopAllExcelFilesInFolder()
' 功能：遍历指定目录下所有Excel文件，复制第一个工作表的有效数据
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
Dim targetSht As Worksheet ' 粘贴目标工作表，可根据需求修改
Dim copyRng As Range

' 这里设置你要粘贴到的工作表，示例是当前代码工作簿的第一个工作表
Set targetSht = ThisWorkbook.Worksheets(1)

' 优化运行速度
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False ' 屏蔽操作弹窗

' 让用户选择目标文件夹
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
    .Title = "选择目标文件夹"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo ResetSettings
    myPath = .SelectedItems(1) & "\"
End With

' 目标文件扩展名
myExtension = "*.xls*"
myFile = Dir(myPath & myExtension)

' 遍历所有文件
Do While myFile <> ""
    On Error Resume Next ' 跳过加密、被其他用户占用的无法打开的文件
    Set wb = Workbooks.Open(Filename:=myPath & myFile, ReadOnly:=True) ' 只读打开避免修改原文件
    On Error GoTo 0
    
    If Not wb Is Nothing Then
        ' 明确指定操作打开的工作簿的第一个工作表，可根据需求修改为指定工作表名称
        With wb.Worksheets(1)
            ' 先判断A1是否有数据，再确定有效数据范围
            If Not IsEmpty(.Range("A1")) Then
                Set copyRng = .Range("A1", .Range("A1").End(xlToRight).End(xlDown))
                ' 粘贴到目标表的下一个空行
                copyRng.Copy targetSht.Cells(targetSht.Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
        End With
        ' 关闭工作簿不保存，因为只是读取不需要修改原文件
        wb.Close SaveChanges:=False
        Set wb = Nothing
    End If
    
    ' 读取下一个文件
    myFile = Dir
Loop

MsgBox "任务完成！"

ResetSettings:
' 恢复Excel默认设置
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

注意事项 #

• 如果需要复制每个文件的所有工作表，可在打开工作簿后加一层工作表遍历循环
• 如果目标文件的有效数据不是从A1开始，可自行修改范围判定逻辑

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