由於近期工作中需要公司彙整各部門傳回之大量資料，不想自己複製貼上幾百次，所以稍微寫了一個小VBA練習，分享給跟我一樣需合併大量資料的網友們。
由於我還是VBA幼幼班，還煩請各位神人指教，謝謝
>需要彙整資料簡述:
多個檔案合併，每個檔案裡有多種表單，名稱分別為1a、1b、2a、2b、3a、3b、4，但各個檔案並非每張資料表都有，另因各個活頁簿檔案為人工繕打，故每個表單裡面有可能有表頭，但沒有資料。
>目標:
依照順序將資料夾中各個檔案中相同名稱的表單合併成單一工作表。
下圖簡單示意一下我要合併的工作表大概長啥樣(大概有150個這種檔案，為了方便解釋，稱為原始檔)
以此做為範例，若有以下兩個檔案中名稱同為"1a"的工作表，欲合併在另一檔案中:
>撰寫邏輯:
讓VBA 依序把資料夾中的原始檔打開，搜尋指定工作表名稱，若有該工作表，則將工作表中的資料選取，複製並貼上到指定檔案。
>開工!(程式碼):
Sub 貼1a()
Const path As String = "C:\Users\Desktop\Users\彙整資料\5月份_6月繳交"
Dim sheetname As String
Dim spfsheet As Worksheet
Dim i as integersheetname = "1a"'打開資料合併要貼上的活頁簿
Workbooks.Open "C:\Users\Desktop\test.xlsm", ReadOnly:=False'打開指定資料夾里全部的excel檔
Filename = Dir(path & "*.xls*")
Do While Filename <> ""
Workbooks.Open Filename:=path & Filename, ReadOnly:=True'抓1a工作表全部資料
On Error Resume Next '確認有名稱為1a的工作表，否則忽略錯誤
Set spfsheet = Worksheets(sheetname)
On Error GoTo 0
If spfsheet Is Nothing Then
MsgBox "無1a"
Else
Worksheets("1a").Activate
Range("A4").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.copy
'MsgBox "複製成功"
workbooks(3).close '關閉複製好的原始檔
workbooks("test").Activate
Worksheets("1a").Activate
Range("A66536").End(xlUp).Select
Selection.Offset(1, 0).Select '往下跳1格(不會有空白)
activesheet.Paste
ActiveWorkbook.Save
workbooks.Close
'MsgBox "貼上成功"
End If
Set spfsheet = Nothing
Filename = Dir()
Workbooks.Close
Loop
End Sub
>完成圖:
>說明:
若有多個不同名稱的工作表需合併，修改程式中指定的工作表名稱即可，自己嘗試後認為若資料量很大的話，不要在一次的巨集中將所有表單一次跑完，因為公司的文書機很容易當掉，而且若有錯誤不容易抓到。
若有想法指教歡迎回覆!^___^
