在职场偶尔会有将多个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