Sub MergeWorkbooks()
    Dim fd As FileDialog
    Dim sPath As String
    Dim sFile As String
    Dim wbSource As Workbook
    Dim sht As Worksheet
    Dim targetSheet As Worksheet
    Dim srcLastRow As Long, srcLastCol As Long
    Dim destLastRow As Long, sourceCol As Long
    Dim srcRange As Range
    Dim fileName As String
    
    ' 用户选择文件夹
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "选择要合并的文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        sPath = .SelectedItems(1)
    End With
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 遍历文件夹中的Excel文件
    sFile = Dir(sPath & "\*.xls*")
    Do While sFile <> ""
        If Not sFile Like ThisWorkbook.Name Then
            Set wbSource = Workbooks.Open(sPath & "\" & sFile, ReadOnly:=True)
            fileName = wbSource.Name
            
            For Each sht In wbSource.Worksheets
                ' 创建或获取目标工作表
                If Not WorksheetExists(sht.Name) Then
                    Set targetSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    targetSheet.Name = sht.Name
                    sht.Rows(1).Copy targetSheet.Rows(1)
                    targetSheet.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Value = "来源"
                Else
                    Set targetSheet = ThisWorkbook.Worksheets(sht.Name)
                End If
                
                ' 获取源数据范围
                srcLastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
                srcLastCol = sht.Cells(1, Columns.Count).End(xlToLeft).Column
                If srcLastRow > 1 Then
                    Set srcRange = sht.Range(sht.Cells(2, 1), sht.Cells(srcLastRow, srcLastCol))
                    
                    ' 复制数据
                    destLastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row + 1
                    srcRange.Copy targetSheet.Cells(destLastRow, 1)
                    
                    ' 添加来源信息
                    sourceCol = targetSheet.Cells(1, Columns.Count).End(xlToLeft).Column
                    targetSheet.Cells(destLastRow, sourceCol).Resize(srcRange.Rows.Count, 1).Value = fileName
                End If
            Next sht
            wbSource.Close False
        End If
        sFile = Dir()
    Loop
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "合并完成！共处理 " & ThisWorkbook.Sheets.Count & " 个工作表。", vbInformation
End Sub

Function WorksheetExists(shtName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Not ThisWorkbook.Worksheets(shtName) Is Nothing
    On Error GoTo 0
End Function