合并文件夹下所有excel

Sub CombineSheets()

    Dim SourceFolder As String
    Dim FileName As String
    Dim wbDestination As Workbook
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim LastRow As Long
    Dim FolderPicker As FileDialog

    ' 创建目标工作簿
    Set wbDestination = Workbooks.Add
    Set wsDestination = wbDestination.Sheets(1)

    ' 用文件对话框选择文件夹
    Set FolderPicker = Application.FileDialog(msoFileDialogFolderPicker)
    With FolderPicker
        .Title = "请选择包含Excel文件的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub '用户点击取消则退出宏
        SourceFolder = .SelectedItems(1)
    End With

    ' 检查路径是否以反斜杠结尾
    If Right(SourceFolder, 1) <> "" Then
        SourceFolder = SourceFolder & ""
    End If

    ' 获取指定文件夹内的第一个Excel文件名
    FileName = Dir(SourceFolder & " *.xls*")

    Do While FileName <> ""

        ' 打开Excel文件
        Set wbSource = Workbooks.Open(SourceFolder & FileName)
        ' 获取第一个sheet
        Set wsSource = wbSource.Sheets(1)

        ' 拷贝内容到目标工作簿
        LastRow = wsDestination.Cells(wsDestination.Rows.Count, "A").End(xlUp).Row
        wsSource.UsedRange.Copy wsDestination.Cells(LastRow + 1, 1)

        ' 关闭源文件
        wbSource.Close savechanges:=False

        ' 获取下一个文件
        FileName = Dir
    Loop

    MsgBox "所有工作表已合并!"

End Sub