多个excel工作簿合并_Excel多个工作簿按Sheet追加型合并到一个工作簿VBA实现

工作 中经常遇 到具有相同版式的多个Excel工作簿，将每个Sheet以追加的方式合并到同一个Excel工作簿中，如下图：

上图只显示了3张表中Sheet1的合并，Sheet2、Sheet3乃至其它均是如此，如果手动操作的话工作量是巨大的，所以，利用Excel自带的VBA宏自动化处理可以化繁为简，极大的提高工作效率。 在此，直接给出我写的代码，需要的同学可以复制，粘贴到需要操作的Excel表格的VBA IDE中，特别说明：

1. 直接使用的宏是：start_append_merged_xlsx；
2. start_append_merged_xlsx实际调用到merged_xlsx_core过程，merged_xlsx_core有两个参数：need_dup_title和need_remove_dup，意义如下：

need_dup_title：是否需要将每张Sheet中的第一列(默认为标题)进行保留，TRUE为保留，FALSE为不保留，默认是FALSE； need_remove_dup：是否在合并工作最后，将完全重复项(以行计，每一列数据都相同才符合完全重复项)去除掉，TRUE是去除，FALSE是不去除，默认是TRUE。

Option Explicit'Sub start_append_merged_xlsx()    'defaule:need_dup_title=FALSE,need_remove_dup = True    merged_xlsx_core False, True    MsgBox "Merge Excel Files Finished!", , "~~"End Sub'Sub merged_xlsx_core(Optional need_dup_title = False, Optional need_remove_dup = True)    Dim xlsx_array, xlsx, v, wb As Workbook, sht, current_row, x, bFind    On Error Resume Next    ChDrive Left(ThisWorkbook.Path, InStr(ThisWorkbook.Path, ":"))    ChDir ThisWorkbook.Path    xlsx_array = Application.GetOpenFilename("Excel Files,*.xls;*.xlsx", , "Open Excel Files", , True)    On Error GoTo NEXT1    If CStr(False) = xlsx_array Then        MsgBox "Open the Excel File Cancelled! Exit"        End    End IfNEXT1:    For Each xlsx In xlsx_array        Set wb = Workbooks.Open(xlsx)        For Each sht In wb.Worksheets            With ThisWorkbook                bFind = False                For Each x In .Worksheets                    If x.Name = sht.Name Then                        bFind = True                        Exit For                    End If                Next                If Not bFind Then                    Set x = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))                    x.Name = sht.Name                End If                          current_row = .Worksheets(sht.Name).UsedRange.Rows.Count                If current_row > 1 Then current_row = current_row + 1                sht.Activate                ActiveSheet.UsedRange.Select                Selection.Copy                .Worksheets(sht.Name).Activate                ActiveSheet.Range("A" & current_row).Select                ActiveSheet.Paste                If Not need_dup_title Then                    If current_row > 1 Then ActiveSheet.Range(current_row & ":" & current_row).Delete Shift:=xlUp                End If            End With            DoEvents        Next        wb.Close    Next    If need_remove_dup Then        For Each sht In ThisWorkbook.Worksheets            Dim arr(), i            sht.Activate            ActiveSheet.Range("A1").Select            ReDim arr(0 To sht.UsedRange.Columns.Count - 1)            For i = 0 To sht.UsedRange.Columns.Count - 1                arr(i) = i + 1            Next            sht.UsedRange.RemoveDuplicates Columns:=(arr), Header:=xlYes            DoEvents        Next    End If    ThisWorkbook.Worksheets(1).ActivateEnd Sub

下面的三个动图就是一次完整操作的演示，其中第一张动图开始阶段，可以新建一个需要汇总的表格，然后，使用快捷键：Alt+F11(同时按Alt和F11两个键)，来调出VBA IDE界面。

至此，合并工作完成，本次分享也告一段落，希望对大家有帮助，欢迎交流，谢谢观赏。