通过VBA宏合并Excel工作表(支持复制行数)

工作中经常会用到的把几个Excel文件合并到一个，或者是把一个Excel文件里的所有Sheet合并到一个Sheet来进行统计。下面分别提供用vba宏来解决这两个问题的方法。

1、合并Excel文件

打开一个空Excel文件，Alt+F11，插入一个模块，开始写代码：

Sub MergeWorkbooks()
    Dim FileSet
    Dim i As Integer
    Dim count As Long
    
    On Error GoTo 0
    Application.ScreenUpdating = False

    FileSet = Application.GetOpenFilename(FileFilter:="Excel 2003(*.xls),*.xls,Excel 2007(*.xlsx),*.xlsx", _
                                            MultiSelect:=True, Title:="选择要合并的文件")
   
    If TypeName(FileSet) = "Boolean" Then
        GoTo ExitSub
    End If
   
    count = 0
    For Each Filename In FileSet
        Workbooks.Open Filename
        Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count)
        count = count + 1
    Next
   
ExitSub:
    Application.ScreenUpdating = True
    Dim msg As String
    msg = "共打开了" & count & "个Excel文件"
    MsgBox msg, vbInformation
End Sub

这段代码的作用：它首先打开一个文件选择框，你可以选择一个或多个文件，然后把这些文件里的所有Sheet合并到当前这个工作簿里来，有重名的Sheet会自动在后面加数字。

2、合并一个EXCEL多个sheet的内容到一个汇总sheet

同上，再添加一个模块吧，代码如下：

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(what:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Sub MergeSheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim shLast As Long
    Dim CopyRng As Range
    Dim StartRow As Long
    Dim EndRow As Long

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    '新建一个“汇总”工作表
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("汇总").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "汇总"

    '开始复制的行号，忽略表头，无表头请设置成1
    StartRow = 6
    EndRow = 10
    'EndRow 要是等于-1就全部复制，第N行不合并

    For Each sh In ActiveWorkbook.Worksheets

        If sh.Name <> DestSh.Name Then
            Last = LastRow(DestSh)
            shLast = LastRow(sh)

            If shLast > 0 And shLast >= StartRow Then
            
                If EndRow <> -1 And EndRow >= StartRow Then
                    Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(EndRow))
                Else
                    Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
                End If
                
                If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                    MsgBox "内容太多放不下啦！"
                    GoTo ExitSub
                End If

                CopyRng.Copy
                With DestSh.Cells(Last + 1, "A")
                    .PasteSpecial xlPasteValues
                    .PasteSpecial xlPasteFormats
                    Application.CutCopyMode = False
                End With
            End If
        End If
    Next

ExitSub:
    Application.GoTo DestSh.Cells(1)
    DestSh.Columns.AutoFit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
   
End Sub

这段代码的作用：它会新建一个叫做“汇总”的工作表，然后把当前工作簿里的所有Sheet里有数据的内容都复制到“汇总”表里。提示：如果数据表里的内容没有表头的话需要把StartRow = 2改成StartRow = 1。

 

下面这段代码执行时会删除 除当前活动的Sheet之外的 其他 所有Sheet，隐藏的Sheet没有尝试过：

Sub sheetdel()
'删除本工作表之外所有工作表，即只保留当前工作表
    Dim sht As Worksheet
    Application.DisplayAlerts = False
    For Each sht In Worksheets
        If sht.Name <> ActiveSheet.Name Then
            sht.Delete
        End If
    Next
    Application.DisplayAlerts = True
End Sub