如何修改VBA代码合并多工作表数据并新增来源工作表名称列

优化后的完整VBA代码（已支持新增来源工作表列） #

Sub 合并所有工作表到总表()

    Dim wrk As Workbook '工作簿对象
    Dim sht As Worksheet '循环遍历用的工作表对象
    Dim trg As Worksheet '合并后的总表（Master）
    Dim rng As Range '单元格区域对象
    Dim colCount As Integer '原始数据表的列数
    Dim lastRow As Long '总表写入的起始行
     
    Set wrk = ActiveWorkbook '在当前活动工作簿中运行
    Const 总表名称 As String = "Master"
    
    '检查是否已经存在同名总表
    For Each sht In wrk.Worksheets
        If sht.Name = 总表名称 Then
            MsgBox "已经存在名为'" & 总表名称 & "'的工作表。" & vbCrLf & _
            "本代码将自动创建该名称的总表，请先删除重名工作表后再运行。", vbOKOnly + vbExclamation, "错误提示"
            Exit Sub
        End If
    Next sht
     
    Application.ScreenUpdating = False '关闭屏幕刷新提升运行速度
     
    '在所有工作表末尾新建总表
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
    trg.Name = 总表名称
    
    '取第一个工作表的表头和列数
    Set sht = wrk.Worksheets(1)
    colCount = sht.Cells(1, 255).End(xlToLeft).Column
    
    '写入表头，最后一列新增来源工作表列
    With trg
        .Cells(1, 1).Resize(1, colCount).Value = sht.Cells(1, 1).Resize(1, colCount).Value
        .Cells(1, colCount + 1).Value = "来源工作表"
        .Cells(1, 1).Resize(1, colCount + 1).Font.Bold = True
    End With
     
    '遍历所有工作表写入数据
    For Each sht In wrk.Worksheets
        If sht.Name = 总表名称 Then
            Exit For
        End If
        '定位当前工作表的有效数据区域（跳过表头，从第二行开始）
        Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
        '找到总表的最后空行作为写入起始行
        lastRow = trg.Cells(65536, 1).End(xlUp).Offset(1).Row
        '写入工作表数据
        trg.Cells(lastRow, 1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
        '对应行填充来源工作表名称
        trg.Cells(lastRow, colCount + 1).Resize(rng.Rows.Count, 1).Value = sht.Name
    Next sht
    
    '自动调整总表所有列宽
    trg.Columns.AutoFit
     
    '恢复屏幕刷新
    Application.ScreenUpdating = True
    MsgBox "合并完成！", vbInformation, "提示"
End Sub

核心修改说明 #

• 在总表表头末尾新增了来源工作表列，格式和原有表头保持一致
• 每写入一个工作表的数据后，同步将对应行的最后一列填充为当前数据的来源工作表名称
• 优化原有葡萄牙语注释、提示框文本为中文，适配国内用户使用习惯

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