VBA宏曾正常运行，现报1004“应用程序定义或对象定义错误”

核心错误原因分析 #

调试指向的复制行触发1004错误，大概率是以下几种情况：

• 打开的文件中没有名为"Summary"的工作表：代码默认所有目标文件都包含这个工作表，但如果某份文件的表被改名、删除，就会直接报错。
• 遍历到非.xlsx格式文件：原代码用*.*遍历所有文件，可能打开了.csv、.txt等非Excel格式文件，这类文件里不存在"Summary"工作表，触发错误。
• 目标列计算逻辑错误：当汇总表"TestData"的第一行完全为空时，Cells(1,1).End(xlToRight)会跳到Excel的最后一列（XFD列），此时emptyColumn +1会超出工作表列数上限，导致报错。
• 汇总工作簿缺少"TestData"工作表：如果当前激活的工作簿里没有这个表，后续所有操作都会失效。

针对性修复方案 #

1. 只遍历.xlsx格式文件 #

将遍历文件的代码从：

mySceFileName = Dir(myFolderName & "*.*")

修改为：

mySceFileName = Dir(myFolderName & "*.xlsx")

避免打开非目标格式的文件。

2. 检查源文件的"Summary"表是否存在 #

打开文件后先做存在性判断，不存在则跳过该文件：

Dim summarySheet As Worksheet
On Error Resume Next
Set summarySheet = SceWb.Sheets("Summary")
On Error GoTo 0
If summarySheet Is Nothing Then
    MsgBox "文件" & mySceFileName & "中未找到Summary工作表，已跳过"
    SceWb.Close False
    mySceFileName = Dir
    GoTo NextLoop
End If

3. 修正空列计算逻辑 #

当第一行全空时，直接将目标列设为1，避免跳到最后一列：

emptyColumn = SummWb.Sheets("TestData").Cells(1, Columns.Count).End(xlToLeft).Column
If emptyColumn = 1 And SummWb.Sheets("TestData").Cells(1,1).Value = "" Then
    emptyColumn = 1
Else
    emptyColumn = emptyColumn + 1
End If

4. 提前验证汇总表"TestData"存在性 #

在代码开头添加检查，避免无意义的后续操作：

On Error Resume Next
Dim testDataSheet As Worksheet
Set testDataSheet = SummWb.Sheets("TestData")
On Error GoTo 0
If testDataSheet Is Nothing Then
    MsgBox "当前工作簿中未找到TestData工作表，请确认后重试"
    Application.ScreenUpdating = True
    Exit Sub
End If

优化后的完整代码 #

Sub SummariseDataCCETR13Test()
    Dim SummWb As Workbook
    Dim SceWb As Workbook
    Dim testDataSheet As Worksheet
    Dim summarySheet As Worksheet
    Dim myFolderName As String
    Dim mySceFileName As String
    Dim emptyColumn As Long
    Dim oldStatusBar As Boolean
    
    '选择目标文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub '用户取消选择则退出
        myFolderName = .SelectedItems(1)
    End With
    If Right(myFolderName, 1) <> "\" Then myFolderName = myFolderName & "\"
    
    '环境设置
    Application.ScreenUpdating = False
    oldStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Set SummWb = ActiveWorkbook
    
    '检查汇总表是否存在
    On Error Resume Next
    Set testDataSheet = SummWb.Sheets("TestData")
    On Error GoTo 0
    If testDataSheet Is Nothing Then
        MsgBox "当前工作簿中未找到TestData工作表，请确认后重试"
        GoTo Cleanup
    End If
    
    '遍历.xlsx文件
    mySceFileName = Dir(myFolderName & "*.xlsx")
    Do While mySceFileName <> ""
        Application.StatusBar = "Processing: " & mySceFileName
        Set SceWb = Workbooks.Open(myFolderName & mySceFileName)
        
        '检查源文件是否有Summary工作表
        On Error Resume Next
        Set summarySheet = SceWb.Sheets("Summary")
        On Error GoTo 0
        If summarySheet Is Nothing Then
            MsgBox "文件" & mySceFileName & "中未找到Summary工作表，已跳过"
            SceWb.Close False
            mySceFileName = Dir
            GoTo NextLoop
        End If
        
        '计算目标空列
        emptyColumn = testDataSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        If emptyColumn = 1 And testDataSheet.Cells(1, 1).Value = "" Then
            emptyColumn = 1
        Else
            emptyColumn = emptyColumn + 1
        End If
        
        '复制数据
        summarySheet.Range("A14:B150").Copy testDataSheet.Cells(1, emptyColumn)
        
        '关闭源文件
        SceWb.Close False
NextLoop:
        mySceFileName = Dir
    Loop
    
Cleanup:
    '恢复环境设置
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatusBar
    SummWb.Activate
    'SummWb.Save '需要自动保存则取消注释
    Application.ScreenUpdating = True
End Sub

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