VBA-快速合并多个Excel工作薄为一个工作薄

在知乎如何快速的合并多个 Excel 工作簿成为一个工作簿？答案的基础上添加了给sheet改名的功能

Function NameOfWorkbook(ByVal strFullPath As String) As String

    Dim FileNameFromPath
    
    FileNameFromPath = Right(strFullPath, Len(strFullPath) - InStrRev(strFullPath, "\"))
    NameOfWorkbook = Left(FileNameFromPath, (InStrRev(FileNameFromPath, ".", -1, vbTextCompare) - 1))

End Function


Sub 工作薄间工作表合并()

Dim FileOpen
Dim X As Integer
Dim WS As Worksheet

Application.ScreenUpdating = False
FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄")
X = 1
While X <= UBound(FileOpen)

Workbooks.Open Filename:=FileOpen(X)

For Each WS In sheets()
   WS.Name = NameOfWorkbook(FileOpen(X)) & "_" & WS.Name
Next WS

sheets().Move After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count)
X = X + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub


errhadler:
MsgBox Err.Description
End Sub

如果你想多个sheet合并到一起，而不是追加sheet的话，请参考这篇百度经验，

Option Explicit
Sub mergeonexls() '合并多工作簿中指定工作表
On Error Resume Next
Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet
Dim t As Workbook, ts As Worksheet, l As Integer, h As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _
       Title:="Excel选择", MultiSelect:=True)
Set t = ThisWorkbook
Set ts = t.Sheets(1) '指定合并到的工作表，这里是第一张工作表
l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column
For Each x1 In x
If x1 <> False Then
 Set w = Workbooks.Open(x1)
 Set wsh = w.Sheets(1) '指定所需合并工作表，这里是第一张工作表
 h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row
 If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then
 wsh.UsedRange.Copy ts.Cells(1, 1)
 Else
 wsh.UsedRange.Copy ts.Cells(h + 1, 1)
 End If
 w.Close
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Sub mergeeveryonexls() '将多个工作簿下的工作表依次对应合并到本工作簿下的工作表，即第一张工作表对应合并到第一张，第二张对应合并到第二张……
On Error Resume Next
Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet
Dim t As Workbook, ts As Worksheet, i As Integer, l As Integer, h As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False
x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _
       Title:="Excel选择", MultiSelect:=True)
Set t = ThisWorkbook
For Each x1 In x
If x1 <> False Then
 Set w = Workbooks.Open(x1)
 For i = 1 To w.Sheets.Count
If i > t.Sheets.Count Then t.Sheets.Add After:=t.Sheets(t.Sheets.Count)
 Set ts = t.Sheets(i)
 Set wsh = w.Sheets(i)
 l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column
 h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row
 If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then
 wsh.UsedRange.Copy ts.Cells(1, 1)
 Else
 wsh.UsedRange.Copy ts.Cells(h + 1, 1)
 End If
 Next
 w.Close
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub