Excle 多个文档合并为一个 分多个sheet页

鼠标放在sheet页标签上邮件选择查看代码
出现
键入一下代码：

Sub Find()
Application.ScreenUpdating = False
Dim MyDir As String
MyDir = ThisWorkbook.Path & "\"
ChDrive Left(MyDir, 1) 'find all the excel files
ChDir MyDir
Match = Dir$("")
Do
If Not LCase(Match) = LCase(ThisWorkbook.Name) Then
Workbooks.Open Match, 0 'open
ActiveSheet.Copy Before:=ThisWorkbook.Sheets(1) 'copy sheet
Windows(Match).Activate
ActiveWindow.Close
End If
Match = Dir$
Loop Until Len(Match) = 0
Application.ScreenUpdating = True
On Error Resume Next
For i = 1 To Worksheets.Count - 1
Sheets(1).Move after:=Sheets(Worksheets.Count - i + 1)
Next
End Sub

点击运行子程序
等待些许时间即可完成。

（注：同一个工作簿中多个sheet页合并成为一个编辑代码：

Sub hb() 
Dim bt, i, r, c, n, first As Long 
bt = 1 '表头行数，多行改为对应数值 
Cells.Clear 
For i = 1 To Sheets.Count 
    If Sheets(i).Name <> ActiveSheet.Name Then 
        If first = 0 Then 
            c = Sheets(i).Cells(1, Columns.Count).End(xlToLeft).Column 
            Sheets(i).Range("A1").Resize(bt, c).Copy Range("A1") 
            n = bt + 1: first = 1 
        End If 
        r = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row 
        Sheets(i).Range("A" & bt + 1).Resize(r - 1, c).Copy Range("A" & n) 
        n = n + r - bt 
    End If 
Next 
End Sub

）