合并多个工作簿

Sub汇总()

Application.ScreenUpdating= False

Application.DisplayAlerts= False

 

Dim i As Long

Dim mySht As Worksheet

Dim fname As String

i= 1

 

'生成查找EXCEL的目录

fname= Dir(ThisWorkbook.Path & '\*.xlsx')

 

'在目录中循环

Do While fname <> ''

    If fname <> ThisWorkbook.Name Then  '如果不是当前的汇总工作簿

        Workbooks.Open ThisWorkbook.Path &'\' & fname '打开工作簿

        '将打开工作簿的第一个sheet复制到当前工作簿的sheeti中

Workbooks(fname).Sheets(1).CopyAfter:=ThisWorkbook.Sheets(i)

 '将新增的sheet命名为打开的工作簿名

        ThisWorkbook.Sheets(i 1).Name =Split(fname, '.')(0)

        '关闭打开的工作簿，不保存

        Workbooks(fname).Close savechanges:=False

    End If

    i = i 1

    fname = Dir

Loop

 

'删除空白的sheet

For Each mySht In ThisWorkbook.Sheets

If IsEmpty(mySht.UsedRange) Then

‘或者 IfApplication.WorksheetFunction.CountA(mySht.cells) = 0 then

    mySht.Delete

    End If

Next

 

Application.DisplayAlerts= True

Application.ScreenUpdating= True

End Sub

----------------------------------------