Sub 文件合并()
On Error Resume Next
Dim sh As Worksheet
Dim wb As Workbook
Dim ThisRow As Long
Dim myf  as Object
Dim Directory, MyPath, MyName, AWbName As String
Set myf = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", &H1)
    
If Not myf Is Nothing Then
    Directory = myf.self.Path  
End If

MyPath = Directory
MyName = Dir(MyPath & "\" & "*.xls*")
AWbName = ThisWorkbook.Name
ThisRow = 1

Do While MyName <> ""
If MyName <> AWbName Then
Set wb = Workbooks.Open(MyPath & "\" & MyName)

        For Each sh In wb.Worksheets
            If Application.CountA(sh.UsedRange.Cells) > 0 Then
               
                 ThisRow = ThisRow + sh.UsedRange.Rows.Count
                 
                 ThisWorkbook.Sheets(1).Range("a" & ThisRow - sh.UsedRange.Rows.Count & ":a" & ThisRow - 1).Value = VBA.Left(MyName, InStrRev(MyName, ".") - 1) & "-" & sh.Name

                 sh.UsedRange.Copy ThisWorkbook.Sheets(1).Range("b" & ThisRow - sh.UsedRange.Rows.Count)
            End If
           
        Next
            

wb.Close True

 End If

MyName = Dir
Loop
End Sub