合并EXCEL工作簿中表格(sheet)的三种情况教程及代码

一、操作方法

将所有要合并的工作簿存放到同目录下，在同目录下新建“汇总工作簿.xls”,打开后，按Alt+F11进入代码编辑界面,点击插入-模块，将代码复制粘贴进去，点击运行。

二、将多个工作簿的所有工作表(sheet)复制到一个工作簿内,代码：

Sub CombineFiles()

Dim path As String

Dim FileNameAs String

Dim LastCellAs Range

Dim WkbAs Workbook

Dim WS As Worksheet

Dim ThisWBAs String

Dim MyDirAs String

MyDir = ThisWorkbook.path& "\"

'ChDriveLeft(MyDir, 1) 'find all the excel files

'ChDirMyDir

'Match = Dir$("")

ThisWB = https://www.360docs.net/doc/d42913510.html,

Application.EnableEvents = False

Application.ScreenUpdating = False

path = MyDir

FileName = Dir(path & "\*.xls", vbNormal)

Do Until FileName = ""

If FileName<>ThisWB Then

Set Wkb = Workbooks.Open(FileName:=path & "\" &FileName)

For Each WS InWkb.Worksheets

Set LastCell = WS.Cells.SpecialCells(xlCellTypeLastCell)

If LastCell.Value = "" And LastCell.Address = Range("$A$1").Address Then

Else

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

End If

Next WS

Wkb.Close False

End If

FileName = Dir()

Loop

Application.EnableEvents = True

Application.ScreenUpdating = True

Set Wkb = Nothing

Set LastCell = Nothing

End Sub

三、将多个工作簿的第一张工作表（sheet）复制到一个工作簿内,代码：Private Sub 合并工作薄()

Dim f_name As String

Dim bok1 As Workbook, bok2 As Workbook

Set bok2 = Nothing

f_name = Dir(ThisWorkbook.Path& "\*.*") '获得该目录下的所有EXCEL文件

Do While f_name<> "" '开始执行循环

If f_name<>https://www.360docs.net/doc/d42913510.html, Then '如果当前的文件不是代码所在文件，执行合并操作

Set bok1 = Workbooks.Open(ThisWorkbook.Path& "\" &f_name) '打开被合并的文件

If bok2 Is Nothing Then '合并后的文件是否存在

bok1.Sheets(1).Copy '如果合并后的文件不存在，则创建一个

Set bok2 = ActiveWorkbook

Else

bok1.Sheets(1).Copy Before:=bok2.Sheets(1) '如果合并后的文件存，在则将被合并文件的第一个工作表复制到合并文件中。

End If

bok1.Close '关闭被合并文件

End If

f_name = Dir() '获取下一个被合并文件名

Loop

End Sub

四、将多个工作簿的所有工作表（sheet）复制到一个工作簿的同一个sheet内,代码：

Sub 合并当前目录下所有工作簿的全部工作表()

Dim MyPath, MyName, AWbName

Dim WbAs Workbook, WbN As String

Dim G As Long

Dim NumAs Long

Dim BOX As String

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

MyName = Dir(MyPath& "\" & "*.xls")

AWbName = https://www.360docs.net/doc/d42913510.html,

Num = 0

Do While MyName<> ""

If MyName<>AWbName Then

Set Wb = Workbooks.Open(MyPath& "\" &MyName)

Num = Num + 1

With Workbooks(1).ActiveSheet

.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4) For G = 1 ToSheets.Count

Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)

Next

WbN = WbN&Chr(13) &https://www.360docs.net/doc/d42913510.html,

Wb.Close False

End With

End If

MyName = Dir

Loop

Range("A1").Select

Application.ScreenUpdating = True

MsgBox "共合并了" &Num& "个工作薄下的全部工作表。如下：" &Chr(13) &WbN, vbInformation, "提示"

End Sub