VBA合并多个EXCEL表代码

合并多个EXCEL表代码
今天工作时，写一个文档，突然需要将多个excel工作簿合并成一个，于是总结一下，希望有用。

1、合并多个EXCEL表为同一个EXCEL表

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer

    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="MicroSoft Excel文件(*.xls),*.xls", _
      MultiSelect:=True, Title:="要合并的文件")


    If TypeName(FilesToOpen) = "Boolean" Then
       MsgBox "没有选中文件"
       GoTo ExitHandler
    End If

    x = 1
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets().Move after:=ThisWorkbook.Sheets _
        (ThisWorkbook.Sheets.Count)
        x = x + 1

    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

用法：新建一个文件夹，将你要合并的excel都拷贝到里面，新建一个excel文件，作为合并的输出。打开刚刚创建的excel，按ALT+F11，代开代码编辑页面，双击sheet1，打开sheet的编辑器，将以上代码拷贝到编辑器，点击工具栏上的运行按钮。所有在文件夹下的excel都被加入到当前的excel文档了，分布在不同的sheet页中。

这个用的比较多



2、合并多个EXCEL表单为同一个表单

Sub test()
    ActiveSheet.UsedRange.ClearContents
    Dim countalla, countthis As Integer
    countallb = 0
    countthis = 0
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> ActiveSheet.Name Then
           countthis = Sheets(i).UsedRange.Rows.Count
           Sheets(i).UsedRange.Copy [a65536].End(xlUp).Offset(1, 1)
           countallb = countallb + countthis
           ActiveSheet.Range("a" & countallb, Range("a" & countallb).End(xlUp).Offset(1, 0)).Value = Sheets(i).Name
        End If
    Next i
End Sub

用法：在当前excel中按ALT+F11，双击sheet1，打开sheet的编辑器，将以上代码拷贝到编辑器，点击工具栏上的运行按钮。





3、多个EXCEL表合并成一个表单

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
    Dim countalla, countthis As Integer
    countallb = 0
    countthis = 0


    On Error GoTo ErrHandler
    Application.ScreenUpdating = False

    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="MicroSoft Excel文件(*.xls),*.xls", _
      MultiSelect:=True, Title:="要合并的文件")


    If TypeName(FilesToOpen) = "Boolean" Then
       MsgBox "没有选中文件"
       GoTo ExitHandler
    End If

    x = 1
    ThisWorkbook.Sheets("合并").UsedRange.ClearContents
    While x <= UBound(FilesToOpen)
        Workbooks.Open Filename:=FilesToOpen(x)
        Sheets().Move after:=ThisWorkbook.Sheets("合并")

        If ThisWorkbook.Sheets(2).Name <> "合并" Then
           countthis = ThisWorkbook.Sheets(2).UsedRange.Rows.Count
           ThisWorkbook.Sheets(2).UsedRange.Copy ThisWorkbook.Sheets("合并").[a65536].End(xlUp).Offset(1, 0)
           countallb = countallb + countthis
           'ThisWorkbook.Sheets("合并").Range("a" & countallb, Range("a" & countallb).End(xlUp).Offset(1, 0)).Value = ThisWorkbook.Sheets(2).Name
           Application.DisplayAlerts = False
           ThisWorkbook.Sheets(2).Delete
           Application.DisplayAlerts = True
        End If

        x = x + 1
    Wend

ExitHandler:
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox Err.Description
    Resume ExitHandler
End Sub

用法同1.