VBA程式碼如下：

Sub s()

pth = "D:\My Documents\" "在這裡輸入檔案所在資料夾的完整路徑

fn = Dir(pth & "*.xls")

Set newbk = Workbooks.Add

Set sht = newbk.Sheets(1)

k = 1

Application.DisplayAlerts = False

Do While fn <> ""

Set wb = Workbooks.Open(pth & fn)

For i = 1 To wb.Sheets.Count

sht.Cells(k, 1) = fn & ":" & wb.Sheets(i).Name

k = k + 1

wb.Sheets(i).UsedRange.Copy

sht.Cells(k, 1).PasteSpecial xlPasteValuesAndNumberFormats

k = sht.UsedRange.Rows.Count + 1

Next

wb.Close False

fn = Dir

Loop

newbk.SaveAs pth & "new.xlsx" "在這裡設定合併檔案的檔名

newbk.Close False

Application.DisplayAlerts = True

End Sub