经常会拷贝单位的一些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

# = False

MyPath = #

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

AWbName = #

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = #(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 #  39;每个excel文件中的工作表遍历

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

Next

WbN = WbN & Chr(13) & #

# False

End With

End If

MyName = Dir

Loop

Range("B1").Select

# = 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

# = False

MyPath = #

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

AWbName = #

Num = 0

Do While MyName <> ""

If MyName <> AWbName Then

Set Wb = #(MyPath & "" & MyName)

Num = Num + 1

With Workbooks(1).ActiveSheet

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

For G = 1 To 1

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

                #(G)# .Cells(.Range("B" & #).End(xlUp).Row + 1, 1)

 Else

#(G)#(1).Copy .Cells(.Range("B" & #).End(xlUp).Row + 1, 1)

End If

Next

WbN = WbN & Chr(13) & #

# False

End With

End If

MyName = Dir

Loop

Range("B1").Select

# = True

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

End Sub