Excel合并表格之vba

Sub 合并当前工作簿下的所有工作表()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
   If Sheets(j).Name <> ActiveSheet.Name Then
       X = Cells(Rows.Count,1).End(xlUp).Row + 1
       Sheets(j).UsedRange.Copy Cells(X, 1)
   End If
Next
Application.ScreenUpdating = True
MsgBox "当前工作簿下的全部工作表已经合并完毕！", vbInformation, "提示"
End Sub 

注意：此代码是把每个sheet里面的内容（包括标题行）直接复制到汇总sheet里了，所以汇总后需要手动删除多余的表头。

2. 将多个工作簿中的表格合并到同一个工作簿的同一张表中

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String

Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xlsx")
AWbName = ActiveWorkbook.Name
Num = 0

Do While MyName <> ""
    If MyName <> AWbName Then
        Set Wb = Workbooks.Open(MyPath & "\" & MyName)
        Num = Num + 1
        With Workbooks(1).ActiveSheet
            .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
            For G = 1 To Sheets.Count
                Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
            Next
            WbN = WbN & Chr(13) & Wb.Name
            Wb.Close False
        End With
    End If
    MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

注意此代码合并的是扩展名为xlsx的工作簿中的表，如果扩展名为xls，请修改代码中红色字体部分，请根据自己的版本更改。

3. 多个工作簿中指定的sheet合并到新的工作簿中

Sub 汇总数据（）
Application.ScreenUpdating = False
Dim wb, wb1 As Excel.Workbook
Dim sh As Excel.Worksheet
s = Split(ThisWorkbook.Name, ".")(1)
f = Dir(ThisWorkbook.Path & "\*" & s) '生成查找EXCEL的目录
Do While f <> "" '在目录中循环
    If f <> ThisWorkbook.Name Then  '如果不是打开的工作簿
        Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f)
        wb.Worksheets("sheet1").Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        ActiveSheet.Name = Split(wb.Name, ".")(0)
        wb.Close
    End If
    f = Dir
Loop
ThisWorkbook.Worksheets("汇总").Activate
Application.ScreenUpdating = True
End Sub