经常会拷贝单位的一些excel电子数据进行合并、分析，而合并过程费时费力，效率低。笔者结合工作实际，编写了VBA通用程序，对excel文件进行合并。

新建一个工作表，命名后保存到和与要合并的excel文件同一个目录下，打开新建的文件，摁 alt + f11,双击工程资源管理器里面的sheet1(sheet1),在右侧的代码区粘贴如下代码。运行。等候一会就OK了。

Sub T( )

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim G As Long

Dim Num As Long

Dim BOX As String

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

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

AWbName = ActiveWorkbook.Name

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then

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

Num = Num + 1

With Workbooks(1).ActiveSheet

.Cells(.Range("B65536").End(xlUp).Row+ 2, 1) = Left(MyName, Len(MyName) - 4)

For G = 1 To Sheets.Count  '每个excel文件中的工作表遍历

Wb.Sheets(G).UsedRange.Offset(1).Copy.Cells(.Range("B65536").End(xlUp).Row + 1, 1)  ‘如果标题行不重复（假设标题一行） .Offset(1) 下移一行，改这个1为标题实际行数

Next

WbN = WbN & Chr(13) & Wb.Name

Wb.Close False

End With

End If

MyName = Dir

Loop

Range("B1").Select

Application.ScreenUpdating = True

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

End Sub

//两段代码小小的区别

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

Dim MyPath, MyName, AWbName

Dim Wb As Workbook, WbN As String

Dim G As Long

Dim Num As Long

Dim BOX As String

Application.ScreenUpdating = False

MyPath = ActiveWorkbook.Path

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

AWbName = ActiveWorkbook.Name

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then

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

Num = Num + 1

With Workbooks(1).ActiveSheet

.Cells(.Range("B" & Rows.Count).End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)

For G = 1 To 1

If Num = 1 Then '如果第一次复制，就进行复制标题

                Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1)

 Else

Wb.Sheets(G).UsedRange.Offset(1).Copy .Cells(.Range("B" & Rows.Count).End(xlUp).Row + 1, 1)

End If

Next

WbN = WbN & Chr(13) & Wb.Name

Wb.Close False

End With

End If

MyName = Dir

Loop

Range("B1").Select

Application.ScreenUpdating = True

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

End Sub