在职场偶尔会有将多个Excel文件合并到同一个Excel文件的需求。这个需求可能又分两种，一种是合并到同一个Excel文件中的同一个工作表中，另一种是合并到同一个Excel文件中的不同工作表。
以下Excel VBA代码就可实现 以上这些功能： 让用户选择一个指定的文件夹，程序可将指定文件夹下面所有Excel文件合并到一个汇总的Excel文件中
实现效果（为简单，在选择的文件夹下只放了2个工作簿）：
原表1：
原表2：
合并后效果1：
合并后效果2：
作者1：Excel小子-Office中国
Sub PickFolder()
'** 使用Shell.Application对象来选择文件夹
Dim objShell
Dim objFolder
Dim strPath As String
Dim ph As String
Dim wk As Workbook, wb As Workbook
Dim sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set objShell = CreateObject("Shell.Application")
'** 显示选择文件夹对话框
Set objFolder = objShell.BrowseForFolder(0, "选择文件目录", 0, 0)
If Not objFolder Is Nothing Then '** 用户选择了文件夹
strPath = objFolder.self.Path
Set wb = Workbooks.Add
ph = Dir(strPath & "\" & "*.xls*")
Do While ph <> ""
Set wk = Workbooks.Open(strPath & "\" & ph)
For Each sh In wk.Worksheets
sh.Copy after:=wb.Worksheets(wb.Worksheets.Count)
Next sh
wk.Close False
ph = Dir
Loop
For Each sh In wb.Worksheets
If WorksheetFunction.CountA(sh.UsedRange) = 0 Then
sh.Delete
End If
Next sh
wb.SaveAs ThisWorkbook.Path & "\合并文档.xlsx"
wb.Close
Else
strPath = ""
End If
Set objFolder = Nothing
Set objShell = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
作者2：江苏大侠- Office中国 （对以上代码改进）
Sub PickFolder()
Dim strPath As String
Dim ph As String
Dim wk As Workbook, wb As Workbook
Dim sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
strPath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Set wb = Workbooks.Add(xlWorksheet)
ph = Dir(strPath & "\" & "*.xlsx")
Do While ph <> ""
Set wk = Workbooks.Open(strPath & "\" & ph)
For Each sh In wk.Worksheets
sh.Copy After:=wb.Sheets(wb.Sheets.Count)
Next sh
wk.Close False
ph = Dir
Loop
wb.Sheets(1).Delete
wb.SaveAs ThisWorkbook.Path & "\合并文档.xlsx"
' wb.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
作者3：江苏大侠- Office中国 （合并到同一个工作表中）
Sub PickFolder()
Dim strPath As String
Dim ph As String
Dim wk As Workbook, wb As Workbook
Dim sh As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
strPath = .SelectedItems(1) & "\"
Else
Exit Sub
End If
End With
Set wb = Workbooks.Add(xlWorksheet)
ph = Dir(strPath & "\" & "*.xls*")
Do While ph <> ""
Set wk = Workbooks.Open(strPath & "\" & ph)
For Each sh In wk.Worksheets
sh.UsedRange.Copy wb.Sheets(1).Range("a65536").End(xlUp).Offset(1, 0)
Next sh
wk.Close False
ph = Dir
Loop
wb.SaveAs ThisWorkbook.Path & "\合并文档.xlsx"
wb.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
