Excel VBA合并多工作表到总表仅复制少量内容故障排查求助

问题原因 #

• 变量溢出错误：代码中存储目标行号的H被定义为Integer类型，最大仅支持32767的数值。247个工作表按每个400行计算总数据量接近10万行，行号超过32767后会触发溢出错误，而代码中使用的On Error Resume Next会直接吞掉所有报错，导致后续所有粘贴操作都无法执行，这是绝大多数工作表内容丢失的核心原因。
• 状态依赖风险：代码大量使用Select、ActiveSheet等依赖界面激活状态的方法，循环过程中很容易出现工作表激活状态异常，导致复制和粘贴的目标对象错乱。
• 目标表不匹配：需求要求汇总到名为Master的总表，但现有代码全部粘贴到Analysis表，和需求不符。
• 错误处理不合理：连续的On Error Resume Next隐藏了所有运行时错误，无法感知报错原因，自然无法定位问题。
• 重复表头问题：现有逻辑会把每个工作表的A1:H1表头都复制到总表，导致总表出现大量重复表头。

修复后代码 #

Sub 汇总到Master总表()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim finalRow As Long
    Dim targetRow As Long ' 替换原Integer类型的H，改用Long支持大行数
    Dim copyStartRow As Integer
    
    ' 关闭屏幕更新大幅提升运行速度
    Application.ScreenUpdating = False
    copyStartRow = 1 ' 第一个工作表需要复制表头，从第1行开始
    
    For Each ws In ActiveWorkbook.Worksheets
        ' 排除不需要汇总的工作表，注意新增排除Master总表本身
        If ws.Name <> "ImportCommand" And ws.Name <> "Analysis" And ws.Name <> "Cities" And ws.Name <> "Master" Then
            ' 获取当前工作表的有效行数
            lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
            ' 获取Master总表的下一个空行
            finalRow = ThisWorkbook.Sheets("Master").Cells(ThisWorkbook.Sheets("Master").Rows.Count, 1).End(xlUp).Row
            targetRow = IIf(finalRow = 1 And copyStartRow = 1, 1, finalRow + 1)
            
            ' 复制数据，不需要选中工作表
            ws.Range("A" & copyStartRow & ":H" & lastRow).Copy
            ' 直接粘贴值到目标位置
            ThisWorkbook.Sheets("Master").Range("A" & targetRow).PasteSpecial Paste:=xlPasteValues
            ' 清空剪贴板
            Application.CutCopyMode = False
            
            ' 后续工作表不再复制表头
            If copyStartRow = 1 Then copyStartRow = 2
        End If
    Next
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
    MsgBox "汇总完成，Master总表有效行数：" & ThisWorkbook.Sheets("Master").Cells(ThisWorkbook.Sheets("Master").Rows.Count, 1).End(xlUp).Row
End Sub

额外说明 #

如果确实需要汇总到Analysis表而非Master表，直接把代码中所有Sheets("Master")替换为Sheets("Analysis")即可。

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