XLSX 表格合并VBA代码

前提： 每个表格的数据格式一致，包含有表头，红色字体部分按情况自行修改。

Sub 合并()

    If MsgBox("是否要汇总明细表？", vbYesNo + vbInformation) = vbNo Then   '提示是否汇总
        Exit Sub
    End If
    
    
    On Error Resume Next '如遇错误继续运行

    Application.ScreenUpdating = False '关闭屏幕刷新

    Application.DisplayAlerts = False '禁用警告提示


    
    Dim ws As Worksheet
    
    Dim i%, fileNum%, deletRow%, sheetsSum%
    Dim sheetNum, sheetName, sheetNameArray
    
    Dim sheetRowTotalArray() As Integer '定义一个动态数组，用于判断合并表格是否成功
    
    sheetNameArray = Array("工作簿1", "工作簿2") '定义工作簿
    
    sheetsSum = UBound(sheetNameArray) - LBound(sheetNameArray) + 1 '计算工作簿总个数
    
    ReDim sheetRowTotalArray(sheetsSum) '定义数组长度
    



    
    '遍历新增工作簿
    
    sheetNum = 1

    For Each sheetName In sheetNameArray
       ThisWorkbook.Sheets.Add Before:=Worksheets(Worksheets.Count) '新增工作簿
       ThisWorkbook.Sheets(sheetNum).Name = sheetName '重命名工作簿
       
       sheetRowTotalArray(sheetNum) = 0 '初始化每一个汇总工作簿的总行数
       
       sheetNum = sheetNum + 1
    Next sheetName
    
    
    
    
    
    
    Dim path, fileName  '定义路径名，被合并表名称

    Dim sourceWb As Workbook

    path = ThisWorkbook.path '指定路径为合并新表所在路径

    fileName = Dir(path & "" & "*文件后缀.xlsx") '从该文件夹内遍历所有要合并的表格
    
    
    
    fileNum = 0 '初始化当前是打开了第几个表格文件
    

    Do While fileName <> ""  '遍历的表格名不为空就进入循环

        
        Set sourceWb = Workbooks.Open(path & "" & fileName) '打开遍历到的表格

        
        sheetNum = 1 '初始化工作簿索引
        For Each sheetName In sheetNameArray
        
            If sourceWb.Sheets(sheetName).AutoFilterMode Then
                sourceWb.Sheets(sheetName).AutoFilterMode = False '去除筛选模式
            End If
        
        
            i = ThisWorkbook.Sheets(sheetName).Range("A" & Rows.Count).End(xlUp).Row + 1 '获取汇总表中A列数据区域最后一行的行号
            
            sourceWb.Sheets(sheetName).UsedRange.Copy '复制分表中的数据
    
            ThisWorkbook.Sheets(sheetName).Cells(i, 1).PasteSpecial Paste:=xlPasteAll '粘贴数据
        
            ThisWorkbook.Sheets(sheetName).Cells(i, 1).PasteSpecial Paste:=xlPasteColumnWidths '粘贴列宽


            sheetRowTotalArray(sheetNum) = sheetRowTotalArray(sheetNum) + sourceWb.Sheets(sheetName).UsedRange.Rows.Count '叠加每一个工作簿的总行数


            '如果当前表格文件不是第一个打开的，则删除该表格工作薄的表头
            If fileNum > 0 Then
                ThisWorkbook.Sheets(sheetName).Rows(i).Delete
            End If
            
            
            sheetNum = sheetNum + 1

        Next sheetName
        

        
        sourceWb.Close (False) '复制粘贴完成后关闭被合并的表
        
        fileName = Dir  '继续遍历

        fileNum = fileNum + 1
    Loop
    
    
    
    
    
    
    
    
    '数据校验和清理
    '
    '
    '
    Dim tmpRowTotal% '定义一个临时变量
    Dim isSuccess As Boolean  '定义是否合并成功
    
    
    isSuccess = True
    

    sheetNum = 1
    For Each sheetName In sheetNameArray
        
        tmpRowTotal = ThisWorkbook.Sheets(sheetName).UsedRange.Rows.Count + fileNum - 1 '获取当前工作簿的总行数，需要加上子表的所有表头并减一行


        If tmpRowTotal <> sheetRowTotalArray(sheetNum) Then '判断是否全部拷贝过来了
            isSuccess = False
            ThisWorkbook.Sheets(sheetName).Delete '按名称删除工作簿
        Else
            ThisWorkbook.Sheets(sheetName).Rows(1).Delete '遍历删除表格的第一行，因为是空白行
            
        End If
        
        sheetNum = sheetNum + 1
        
    Next sheetName
    
    
    
    If isSuccess Then
    
        sheetsSum = sheetsSum + 1
    
        ThisWorkbook.Sheets(sheetsSum).Delete '删除最后一个工作簿
            
        MsgBox "工作表合并完毕"
    Else
        
        MsgBox "合并失败，总行数不相等！！！"
    End If
    
    
    
    
    

    Application.DisplayAlerts = True '恢复警告提示

    Application.ScreenUpdating = True '开启屏幕刷新

    

End Sub