合并多个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

这种合并会出现sheet名,而且是一条条向下添加


3、如果需要无sheet名,且是每一个sheet表copy完后,向右增加,则需要


Sub test()
    ActiveSheet.UsedRange.ClearContents
    Dim countalla, countthis, s As Integer
    countallb = 0
    countthis = 0
    s = 1
    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, s)
           s = s + 3
           countallb = countallb + countthis
        End If
    Next i
End Sub


4、多个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