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