Excel VBA合并工作表代码报‘Application defined or Object defined error’求助

需求说明 #

需对包含多张固定结构工作表的工作簿执行以下操作：

• 在所有工作表的最后空白列填充对应工作表名称
• 删除所有工作表的B、C、D、E、F列
• 将所有工作表的已用数据区域合并到新建的"Master"工作表中

输入数据示例 #

PARTICULARS H1  H2  H3  H4  H5  H6  H7  H8  H9  H10 H11 H12 H14 H15
AA          1   2   3   4   5   6   7   8   9   10  11  12  13  
BB          14  15  16  17  18  19  20  21  22  23  24  25  26  
CC          27  28  29  30  31  32  33  34  35  36  37  38  39  

工作表名称：ECSTASY、BEAUTY等

期望输出示例 #

PARTICULAR H6   H7  H8  H9  H10 H11 H12 H14 H15 SheetName
AA          6   7   8   9   10  11  12  13  ECSTASY
BB          19  20  21  22  23  24  25  26  ECSTASY
CC         32   33  34  35  36  37  38  39  ECSTASY
AA         6    7   8   9   10  11  12  13  BEAUTY
BB        19    20  21  22  23  24  25  26  BEAUTY
CC        32    33  34  35  36  37  38  39  BEAUTY
etc.

原代码及错误 #

原代码在执行ws.Range(ws.Cells(1, 1), ws.Cells(srcLastRow, srcLastCol - 5)).Copy masterWs.Cells(destLastRow, 1)时出现"Application-defined or Object-defined error"错误：

Sub CombineSheets()

Dim ws As Worksheet
Dim masterWs As Worksheet
Dim srcLastRow As Long, srcLastCol As Long
Dim destLastRow As Long

' Create the "Master" sheet
Set masterWs = ThisWorkbook.Worksheets.Add
masterWs.Name = "Master"

' Iterate through each worksheet
For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> "Master" Then
        ' Fill the last empty column with the sheet name
        srcLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
        ws.Cells(1, srcLastCol).Value = ws.Name
        
        ' Delete columns B, C, D, E, and F
        ws.Range("B:F").Delete
        
        ' Find the last row in the source and destination sheets
        srcLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        destLastRow = masterWs.Cells(masterWs.Rows.Count, 1).End(xlUp).Row + 1
        
        ' Copy the data from the source sheet to the "Master" sheet
        ws.Range(ws.Cells(1, 1), ws.Cells(srcLastRow, srcLastCol - 5)).Copy masterWs.Cells(destLastRow, 1)
    End If
Next ws

' Clean up
Set ws = Nothing
Set masterWs = Nothing

End Sub

错误原因分析 #

• 列索引计算失效：srcLastCol是删除B:F列前的列数，删除列后工作表列结构左移5位，用srcLastCol -5计算目标列会超出当前有效列范围，触发对象定义错误。
• 工作表名称填充不完整：原代码仅给新列第一行赋值，未覆盖所有数据行，不符合需求。
• 表头重复复制：每个工作表的表头都会被复制到Master表，导致表头重复出现。

修正后的代码 #

Sub CombineSheets()
    Dim ws As Worksheet
    Dim masterWs As Worksheet
    Dim srcLastRow As Long, srcLastCol As Long
    Dim destLastRow As Long
    Dim isFirstSheet As Boolean
    
    ' 检查Master表是否存在，不存在则新建
    On Error Resume Next
    Set masterWs = ThisWorkbook.Worksheets("Master")
    If Err.Number <> 0 Then
        Set masterWs = ThisWorkbook.Worksheets.Add
        masterWs.Name = "Master"
    End If
    On Error GoTo 0
    
    isFirstSheet = True
    
    ' 遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Master" Then
            ' 获取当前工作表的最后数据行和新增列位置
            srcLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            srcLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column + 1
            
            ' 给所有数据行填充工作表名称，同时设置列标题
            ws.Cells(1, srcLastCol).Value = "SheetName"
            ws.Range(ws.Cells(2, srcLastCol), ws.Cells(srcLastRow, srcLastCol)).Value = ws.Name
            
            ' 删除B:F列
            ws.Range("B:F").Delete
            
            ' 重新获取删除列后的最后一列
            srcLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
            
            ' 获取Master表的目标起始行
            destLastRow = masterWs.Cells(masterWs.Rows.Count, 1).End(xlUp).Row
            
            ' 第一个工作表复制表头+数据，后续仅复制数据行
            If isFirstSheet Then
                ws.Range(ws.Cells(1, 1), ws.Cells(srcLastRow, srcLastCol)).Copy masterWs.Cells(1, 1)
                isFirstSheet = False
            Else
                ws.Range(ws.Cells(2, 1), ws.Cells(srcLastRow, srcLastCol)).Copy masterWs.Cells(destLastRow + 1, 1)
            End If
        End If
    Next ws
    
    ' 清理对象变量
    Set ws = Nothing
    Set masterWs = Nothing
End Sub

修正说明 #

1. 修复列索引问题：删除列后重新获取当前工作表的最后一列，确保复制区域的列索引始终有效。
2. 完整填充工作表名称：覆盖所有数据行填充工作表名称，并为新列添加明确表头。
3. 避免表头重复：通过isFirstSheet标记控制仅首次复制表头，后续仅复制数据行。
4. 增加容错处理：检查Master表是否存在，避免重复创建导致的错误。

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