excel vba 将多张数据表的内容合并到一张数据表

功能描述： 

一个Excel文件有很多个 样式相同 的数据表，

需要将多张数据表的内容合并到一张数据表里。

vba实现代码如下：

Attribute VB_Name = "NewMacros"
Option Explicit
Public Const Const_OutSheetName As String = "VBA汇总"
Public Const Const_PZSheetName As String = "配置"

Sub 汇总()
Attribute 汇总.VB_Description = "宏由 LiuZW 录制，时间: 2023/08/19"
Attribute 汇总.VB_ProcData.VB_Invoke_Func = " 14"
'
' 汇总 Macro
' 宏由 LiuZW 录制，时间: 2023/08/19
'

'

    Dim i, j, k As Integer
        
    
    '创建“配置”数据表并提示用户填写配置
    Dim isExistPZ As Boolean
    isExistPZ = False
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = Const_PZSheetName Then
            isExistPZ = True
            Exit For
        End If
    Next
    
    '定义表示要复制的区域的变量
    Dim mRow1, mColumn1, mRow2, mColumn2 As Integer
        
    If isExistPZ Then
        mRow1 = Application.Worksheets(Const_PZSheetName).Range("B2").Value
        mRow2 = Application.Worksheets(Const_PZSheetName).Range("B3").Value
        mColumn1 = Application.Worksheets(Const_PZSheetName).Range("B4").Value
        mColumn2 = Application.Worksheets(Const_PZSheetName).Range("B5").Value
       
       If mRow1 = 0 Or mRow2 = 0 Or mColumn1 = 0 Or mColumn2 = 0 Then
       
            '提示用户填写
            MsgBox ("请填写配置数据表后运行。")
            Exit Sub
       End If
       
       '配置的填写有效性判断
       If Not IsNumeric(mRow1) Or Not IsNumeric(mRow2) Or Not IsNumeric(mColumn1) Or Not IsNumeric(mColumn2) Then
            MsgBox ("配置数据表中键入的区域表述无效，请键入数字格式的行列号。")
            Exit Sub
       End If
       
    
    Else
        '创建“配置”数据表
        Sheets.Add
        ActiveSheet.name = Const_PZSheetName
        
        '填写基础信息
        Application.Worksheets(Const_PZSheetName).Range("A1").Value = "不需要汇总的数据表名称"
        Application.Worksheets(Const_PZSheetName).Range("B1").Value = Const_PZSheetName
        Application.Worksheets(Const_PZSheetName).Range("C1").Value = Const_OutSheetName
        Application.Worksheets(Const_PZSheetName).Range("A2").Value = "复制区域的起始行"
        Application.Worksheets(Const_PZSheetName).Range("A3").Value = "复制区域的终止行"
        Application.Worksheets(Const_PZSheetName).Range("A4").Value = "复制区域的起始列"
        Application.Worksheets(Const_PZSheetName).Range("A5").Value = "复制区域的终止列"
        
        '提示用户填写
        MsgBox ("请填写配置数据表后运行。")
        Exit Sub
    End If
    
    '判断是否已有“VBA汇总”数据表
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = Const_OutSheetName Then
            MsgBox ("要生成的数据表“" + Const_OutSheetName + "”存在同名数据表，请修改或删除同名数据表后重试。")
            Exit Sub
        End If
    Next
    
    '创建“VBA汇总”数据表
    Sheets.Add
    ActiveSheet.name = Const_OutSheetName
    Columns("A:A").Select
    Selection.NumberFormatLocal = "@"
      
    '复制各个数据表的数据并粘贴到汇总表
    For i = 1 To Worksheets.Count
        Dim mSheetName As String
        mSheetName = Worksheets(i).name
        
        '判断当前数据表是否为 无需汇总的数据表
        'MsgBox ("当前数据表的第一行一共有" + CStr(Application.CountA(Sheets(Const_PZSheetName).Rows(1))) + "个数据")
        
        '定义当前数据表是否为 无需汇总的数据表 的标记，True表示无需汇总，False表示需要汇总
        Dim mKey As Boolean
        mKey = False
        
        For j = 2 To Application.CountA(Sheets(Const_PZSheetName).Rows(1))
            If mSheetName = Sheets(Const_PZSheetName).Cells(1, j) Then
                'MsgBox ("当前数据表“" + mSheetName + "”是不需要汇总的数据表")
                mKey = True
                Exit For
            End If
        Next
        
        '如果当前数据表不是 无需汇总的数据表，就执行汇总
        If mKey = False Then
        
            '执行复制和粘贴
            
            
            
            Application.Worksheets(mSheetName).Activate
            Application.Worksheets(mSheetName).Range(Cells(mRow1, mColumn1), Cells(mRow2, mColumn2)).Select
            Selection.Copy
            
            '判断要粘贴的位置并粘贴
            Application.Worksheets(Const_OutSheetName).Activate
            Dim usableRowCount As Integer
            usableRowCount = Application.Application.Sheets(Const_OutSheetName).Range("b65536").End(xlUp).Row + 2
            Application.Worksheets(Const_OutSheetName).Cells(usableRowCount, 2).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
            
            '填充第一列
            For k = 0 To mRow2 - mRow1
                Application.Worksheets(Const_OutSheetName).Cells(usableRowCount + k, 1).Value = mSheetName
            Next
            
        End If
    Next
End Sub

 文件链接：数据表合并.bas

下载后直接在excel 查看代码处导入文件即可。