2021-06-24

如何用VBA快速搞定多个工作簿合并成1个工作簿？

1、首先将要合并的工作簿放在同一个文件夹内；

2、新建一个excel，命名为合并工作簿模板。单击开发工具——插入按钮，命名为：合并工作簿，输入代码：

Sub 合并工作簿()

    Dim Wb As Workbook, MyPath As String, File, Sh_n As String

    Application.ScreenUpdating = False

    Rem 关闭屏幕刷新

    MyPath$ = ThisWorkbook.Path & "\"

    Rem 获取当前工作簿路径

    File = Dir(MyPath & "*.xls*")

    Rem 获取路径下所有Excel文件

    Do While File <> "" '遍历所有文件

        If File <> ThisWorkbook.Name Then '不合并当前工作簿

            Set Wb = Workbooks.Open(MyPath & File)

            Rem 依次打开工作簿

            Sh_n = StrReverse(Mid(StrReverse(Wb.Name), InStr(StrReverse(Wb.Name), ".") + 1))

            Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)

            ActiveSheet.Name = Sh_n

            Rem 将第一个表复制到当前工作簿的最后一个工作表

            Wb.Close False '关闭工作簿 不保存

        End If

        File = Dir

        Rem 循环下一个工作簿

    Loop

    Application.ScreenUpdating = False

    Rem 打开屏幕刷

End Sub

多个sheet合并成一个sheet

Sub hb()

Dim bt, i, r, c, n, first As Long

bt = 1 '表头行数，多行改为对应数值

Cells.Clear

For i = 1 To Sheets.Count

    If Sheets(i).Name <> ActiveSheet.Name Then '务必当前在新建的空白页面中

        If first = 0 Then

            c = Sheets(i).Cells(1, Columns.Count).End(xlToLeft).Column '获取字段数https://www.cnblogs.com/acetaohai123/p/6505447.html

            Sheets(i).Range("A1").Resize(bt, c).Copy Range("A1") '拷贝第一行,也就是head line

            n = bt + 1: first = 1

        End If

        r = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row '获取要拷贝的sheet的行数

        Sheets(i).Range("A" & bt + 1).Resize(r - 1, c).Copy Range("A" & n) '拷贝当前sheet中的数据到第N行

        n = n + r - bt '更新行数变量n

    End If

Next

End Sub