iT邦幫忙

1

VBA 自動化合併多檔案中的同一名稱表單中資料

由於近期需要彙整大量資料,不想自己複製貼上幾百次,所以稍微寫了一個小VBA程式,因為我還是幼幼班(這是我的第一個VBA程式),還請各位大大多多包容寫的很奇怪的地方,感恩

需要彙整資料簡述:
多個檔案合併,每個檔案裡有多種表單,名稱分別為1a、1b、2a、2b、3a、3b、4,須將各個檔案中相同名稱的表單合併成一完整檔案,但各個檔案並非每張資料表都有,所以必須使用名稱進行搜尋,另因各個活頁簿檔案為人工繕打,故每個表單裡面有可能有表頭,但沒有資料。下圖簡單示意一下我要合併的工作表大概長這樣
https://ithelp.ithome.com.tw/upload/images/20200713/20128608ECU3JAzv6B.png

實際程式內容:

Sub 貼1a()
'指定抓取檔案路徑
Const path As String = "C:\Users\Desktop\彙整資料\5月份_6月繳交\"

Dim sheetname As String
Dim spfsheet As Worksheet

sheetname = "1a"

'打開指定資料夾里全部的excel檔
Filename = Dir(path & "*.xls*")
Do While Filename <> ""
    Workbooks.Open Filename:=path & Filename, ReadOnly:=True
'抓取1a工作表全部資料(此sheet非每個檔案都有,無法以順序指定)
    On Error Resume Next 
    Set spfsheet = Worksheets(sheetname)
    On Error GoTo 0
    If spfsheet Is Nothing Then
    Else
        Worksheets("1a").Activate
        If Trim(Range("A4")) = "" Then
        Else
            Range("A4").Select
            Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
            Selection.copy
    
            '開啟要貼上的工作表
            Workbooks.Open "C:\Users\Desktop\test.xlsm", ReadOnly:=False
    
            Worksheets("1a").Activate
            Range("A66536").End(xlUp).Select
            Selection.Offset(1, 0).Select '往下跳1格(不會有空白)
            activesheet.Paste
            ActiveWorkbook.Save
            ActiveWorkbook.Close
        End If
        
    End If
    Set spfsheet = Nothing
    Filename = Dir()
    Workbooks.Close
    
Loop
Workbooks.Open "C:\Users\Desktop\test.xlsm", ReadOnly:=False
Worksheets("1a").Activate
Range("A4:A66536").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub

目前小妹我程式運行部分沒有問題,也可以完整的將檔案合併至指定檔案,但因對於vba的觀念還很不清楚,有幾個部分想請問各位版大:
1.在確認現在開啟的這個活頁簿是否有1a時,我不太了解為什麼需要用到on error resume next,為什麼直接寫If worksheets("1a") is nothing then會出現"此處需要物件的錯誤"呢?
2.如圖所見在B欄的儲存格是有塗色的,所以在運行向下選取要複製的儲存格時,便會連沒有資料,但有顏色的區塊一起選取,所以在loop結束後我會統一將空白儲存格整列刪除,想請問版大有沒有其他選取方式可以避開選取有顏色的空白儲存格?因每個檔案的工作表資料量都不一,若要確認A欄的每列儲存格是否都有資料,一一去確認儲存格的值是否為空白至A66536,似乎不是很合適。

先謝謝各位版大的解答了!

1 個回答

2
海綿寶寶
iT邦大神 1 級 ‧ 2020-07-13 07:44:35

第1題
On Error Resume Next 是「忽略發生的錯誤,程式繼續往下執行」
程式的目的是「處理目錄下的所有 xls 檔案」
但是並不是每一個檔案都有 1a 表單
如果碰到沒有 1a 表單的檔案程式
程式還是要繼續處理下一個檔案
而不是發生錯誤停止執行
所以就用 On Error Resume Next

第2題
不待招式用老

Range("A4").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select

改成

Range("A65536").End(xlUp).Select
Range("A4:C" & ActiveCell.Row).Select

試試看

我要發表回答

立即登入回答