VBA 合併多個excel表的sheet頁進行

工作原因，需要統計所有單位的帳號資訊，但是每個單位的帳號都分散在各自的excel表格裡，因此需要把多個execel表格的相同的某個sheet頁做合併。

大致步驟拆分，分別搜了下VBA，拼湊了三天搞定，還是有點成就感的

1. 數據：把原始檔放在一個資料夾（XX\原始檔\檔案1.xslx 檔案2.xlsx）需要合併到的目標檔案放在XX\目標檔案.xlsx

2. 環境：開啓目標檔案，選擇某個sheet頁，右鍵選擇「檢視程式碼」，插入模組後貼上下面 下麪的程式碼即可。

3. 步驟：（1）遍歷開啓檔案；（2）從原始檔中複製，貼上到目標檔案sheet2的行列裏面。

Rem 將資料夾中所有excel表格某一sheet頁複製到新excel表格某sheet頁裡。建立目標檔案，在同路徑下\原始檔\下放入所有原始檔，複製標準化的「專案經理」sheet頁

Sub hebing()

    Dim myPath, myName
    Dim wb, wbnow As Workbook
    Dim ws, wsnow As Worksheet
    Dim rg As Range
    Dim num, sheetcount, rcount, clcount, i, j, totalnum As Long
    
    Set wb = Workbooks(1)
    
    Rem 把本表格sheet1複製到sheet3前面
    'wb.Sheets(1).Copy before:=wb.Sheets(3)
    Rem 把本表格sheet1的部分割區間貼上到sheet3的某個表格裏面
'    wb.Sheets(1).Range("A" & 1 & ":C" & 3).Copy
'    ActiveSheet.Paste Destination:=wb.Sheets(3).Range("C3:F8")
'
    Rem 清理目標檔案目標sheet頁內容
    wb.Sheets(2).UsedRange.ClearContents
    num = 0
    totalnum = 0
    sheetcount = 1
    i = 1
    j = 1
    myPath = wb.Path
    Debug.Print "myPath = " & myPath
    
    myName = Dir(myPath & "\原始檔\" & "*.xls*")  'myName string
    
    Rem 便利本檔案所在目錄\原始檔 下所有的 excel 表格
    Do While myName <> ""
         Debug.Print "myName = " & myName
         num = num + 1  '處理完成的表格計數
         
         Rem 開啓本檔案路徑下 「原始檔」選單下的excel表格
         Debug.Print ("open 語句：" & myPath & "\原始檔\" & myName)
         Set wbnow = Application.Workbooks.Open(myPath & "\原始檔\" & myName)
'        Debug.Print ("wbnow = " & wbnow.Name)
         
         Rem 找到「專案經理」sheet頁，獲取有效行數，提取內容複製到本表格sheet中
         Set wsnow = wbnow.Sheets("專案經理")
         rcount = wsnow.UsedRange.Rows.Count
         totalnum = totalnum + rcount - 1
'        clcount = wsnow.UsedRange.Columns.Count
         j = j + rcount
         
         Rem 如果第一個檔案則複製表頭，否則第一行不復制
         If num = 1 Then
            wsnow.Range("A1" & ":G" & rcount).Copy
            ActiveSheet.Paste Destination:=wb.Sheets(2).Range("A" & i & ":G" & j)
         Else
         Rem 如果不是第一個檔案，則下次貼上的內容的首行往前一格
            wsnow.Range("A2" & ":G" & rcount).Copy
            j = j - 1
            ActiveSheet.Paste Destination:=wb.Sheets(2).Range("A" & i & ":G" & j)
            i = i - 1
         End If
         Debug.Print ("paste OK !!")
         
         Rem 把原始檔有效行列數複製到本檔案的sheet2裏面
        
         i = i + rcount
         Debug.Print ("檔案 " & wbnow.Name & " 有專案經理複製完成： " & rcount & "行 " & clcount & "列")
         wbnow.Close True
         Rem 繼續遍歷下一個檔案
         myName = Dir()
    Loop
    
    j = wb.Sheets(2).UsedRange.Rows.Count
    
    Debug.Print "完成" & num & "個檔案, " & totalnum & "行。 彙總後" & j & "行！"
    MsgBox "完成" & num & "個檔案, " & totalnum & "行。 彙總後" & j & "行！", vbOKOnly, "不錯哦！"
    

End Sub

結果這個框蠻好看的，1610是把所有原始檔剔除了第一行的有效數據行，第二個1611是含了表頭第一行。