'注意:這裡默認xlsx，如果數據源為xls請自行變更
Sub zhhebing9()
Dim FileOpen
Dim X As Integer
Application.ScreenUpdating = False
FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xlsx),*.xlsx", MultiSelect:=True, Title:="合併工作薄")
X = 1
While X <= UBound(FileOpen)
Workbooks.Open Filename:=FileOpen(X)
Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
X = X + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Exit Sub
errhadler:
MsgBox Err.Description
End Sub

'注意:A列單元格為空時停止，無法匯入空單元格以下內容
Sub zhhebing0()
Application.ScreenUpdating = False
For j = 1 To Sheets.Count
If Sheets(j).Name <> ActiveSheet.Name Then
X = Range("A65536").End(xlUp).Row + 1
Sheets(j).UsedRange.Copy Cells(X, 1)
End If
Next
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "當前工作簿下的全部工作表已經合併完畢！", vbInformation, "提示"
End Sub

Sub zh_mulu()
For Each sh In Sheets
k = k + 1
'注意:1可以改為你想賦予的列號
Cells(k, 1) = sh.Name
Next
End Sub

'注意:默認xlsx，如果數據源為xls請自行變更
'注意:這個功能需要數據表樣和新建的表放在一起
'如果擴充此功能變更第四行MyPath
'注意:A列單元格為空時停止，無法匯入空單元格以下內容
Sub zhhebing1()
Dim MyPath$, MyName$, sh As Worksheet, sht As Worksheet, m&
Set sh = ActiveSheet
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xlsx")
Application.ScreenUpdating = False
Cells.ClearContents
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
With GetObject(MyPath & MyName)
For Each sht In .Sheets
If IsSheetEmpty = IsEmpty(sht.UsedRange) Then
m = m + 1
If m = 1 Then
sht.[a1].CurrentRegion.Copy sh.[a1]
Else
sht.[a1].CurrentRegion.Copy sh.[a65536].End(xlUp).Offset(1)
End If
End If
Next
.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
End Sub