用excel vba 抓取多個excel檔特定儲存格資料複製到新的excel特定欄位_更新

excel vba 資料夾多個檔案

ispiration 2019-06-13 16:53:46 ‧ 31538 瀏覽

我現在遇到一個問題，現在我的資料夾裡有一些excel檔，如圖1，其中一個是評等彙總檔，設有統編，公司名稱，行業別，信用分數，信用評等共5個欄位。我現在要從這資料夾的其他excel檔把這些欄位資料彙整到這個評等資料檔，這些欄位資料的位置，依照檔名包含test1及test2存放在不同的儲存格，例如檔名包含test1者，信用分數及信用評等欄位存放於D3 & D4, 但是檔名包含test2者，信用分數及信用評等欄位則存放在F3 & F4，我想要寫一個VBA把這5個檔案的資料抓到評等彙總檔，請問要如何撰寫，煩請不吝分享，謝謝。

看更多先前的討論...收起先前的討論...

來杯拿鐵 iT邦新手 2 級 ‧ 2019-06-13 22:00:08 檢舉

麻辣家族論壇二樓GBKEE
http://forum.twbts.com/thread-13094-1-1.html

查詢資料夾內全部Excel名稱，再來用「跨檔案參照」，就可以寫出你想要的程式。

ispiration iT邦新手 5 級 ‧ 2019-06-14 10:36:12 檢舉

我現在可以把資料夾內的excel檔名稱抓進我建立的excel檔
請問一下跨檔案參照是否就是用Indirect()函數，可是若把案關閉，Indirect出來的結果就會是error 請問這樣如何處理

paicheng0111 iT邦大師 5 級 ‧ 2019-06-14 14:59:43 檢舉

Indirect()函數確實會有這樣的弊病。
只能改用Lookup()或直接填入該儲存格位置。

ispiration iT邦新手 5 級 ‧ 2019-06-14 15:57:22 檢舉

因為考量可能遇到的狀況，可能需要寫vba，我把問題具體更新了一下，煩請您再看看

ispiration iT邦新手 5 級 ‧ 2019-06-14 16:05:02 檢舉

我參考網路上的vba範例如下
Sub HzWb()
Dim bt As Range, r As Long, c As Long
r = 1 '1 是表頭的行數
c = 7 '7 是表頭的列數
Dim wt As Worksheet
Set wt = ThisWorkbook.Worksheets(1) '將匯總表指定為變數wt
wt.Rows(r + 1 & ":1048576").ClearContents '清除匯總表中原有的資料，只保留表頭
Application.ScreenUpdating = False
Dim FileName As String, sht As Worksheet, wb As Workbook
Dim Erow As Long, fn As String, arr As Variant
FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then '判斷檔案是否為匯總資料的活頁簿
Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1 '取得匯總表中第一條空行行號
fn = ThisWorkbook.Path & "\" & FileName '將第1個要匯總的活頁簿名稱指定為變數fn
Set wb = GetObject(fn) '將變數fn 代表的活頁簿物件指定為變數wb
Set sht = wb.Worksheets(1) '將要匯總的工作表指定為變數sht
'將工作表中要匯總的記錄保存在陣列arr中
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 5))
'將陣列arr 中的資料寫入工作表
wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
FileName = Dir '用Dir 函數取得其他檔案名，並指定為變數
Loop
Application.ScreenUpdating = True
End Sub
因為上面的案例情境是來源資料欄位格式跟匯總表的欄位格是一樣，跟我現在的狀況不一樣，所以我改寫的時候在arr那一段就過不去，請問我可以怎麼改，感謝幫忙

ispiration iT邦新手 5 級 ‧ 2019-06-14 17:15:18 檢舉

以下是我改寫的部分
Sub test2()
Dim bt as Range, r as Long, c as Long
r=1 ' 表頭的行數
c=5 '表頭的列數

Dim wt as Worksheet
Set wt = ThisWorkbook.Worsheets(3) '將彙整表指定為變數wt
wt.Rows(r+1 & ":1048576").ClearContents '清除彙總表原有資料

Application.ScreenUpdating = False
Dim Filename as String, sht as Worksheet, wb as Workbook
Dim erow as Long, fn as String, arr as Variant
Filename = Dir(Thisworkbook.Path & "\*.xls")

Do While Filename <> ""
erow = wt.Range("A1").CurrentRegion.Rows.Count + 1
fn = Thisworkbook.path & "\" & Filename
set wb = getobject(fn)
set sht = wb.worksheets(1)
arr = sht.Range("D13, D12, D14, F8, F9")
wt.cells(erow, "A").resize(ubound(arr,1),ubound(arr,2)) = arr
wb.close False
end if
Filename = Dir
Loop
Application.Screenupdating = True
End Sub

執行到arr那一行就掛掉，我的寫法是arr是由來源檔案中的D13 D12 D14 F8 F9等5個儲存格組成，再把arr寫到彙整檔的A1 ~ A5，第二個檔案則是B1~B5以此類推，我估計我改的arr寫法應該是有錯，不知要如何改才會對?惠請不吝指教

登入發表討論

直播研討會

{{ item.channelVendor }} {{ item.webinarstarted }} |

直播中

2 個回答

paicheng0111

iT邦大師 5 級 ‧ 2019-06-14 18:02:33

最佳解答

我沒測過，你試試看。

Sub test2()
    Dim bt as Range, r as Long, c as Long
    Dim wt as Worksheet
    Dim Filename as String, wb as Workbook
    Dim erow as Long, fn as String, arr as Variant
    r=1 ' 表頭的行數
    c=5 '表頭的列數

    Set wt = ThisWorkbook.Worksheets(3) '將彙整表指定為變數wt
    Range(wt.Rows(2), wt.Rows(Rows.count)).ClearContents '清除彙總表原有資料

    Application.ScreenUpdating = False
    Filename = Dir(Thisworkbook.Path & "\*.xls")

    Do While Filename <> ""
        erow = wt.Range("A1").CurrentRegion.Rows.Count + 1
        fn = Thisworkbook.path & "\" & Filename
        Set wb = workbooks.open(fn)
        With wb.worksheets(1)
            arr = Array(.[D13], .[D12], .[D14], .[F8], .[F9])
            wt.cells(erow, "A").resize(ubound(arr,1),ubound(arr,2)) = arr
            .Parent.Close False
        End With
        Filename = Dir
    Loop
    
    Set wb = Nothing
    Set wt = Nothing
    Application.ScreenUpdating = True
End Sub

回應 6
分享
檢舉

看更多先前的回應...收起先前的回應...

ispiration iT邦新手 5 級 ‧ 2019-06-14 22:41:19 檢舉

感謝高手不吝分享，我跑了一下，出現以下的訊息，是我物件名稱設定錯了嗎?再麻煩您有空看一下謝謝

paicheng0111 iT邦大師 5 級 ‧ 2019-06-15 16:04:23 檢舉

typo Worsheets -> Worksheets

ispiration iT邦新手 5 級 ‧ 2019-06-17 09:34:43 檢舉

謝謝我消化一下您的大作，有問題再請教您

ispiration iT邦新手 5 級 ‧ 2019-06-17 11:17:45 檢舉

朋友你好
我試了一下程式出現以下的訊息 !
是不是因為sheet名稱是(二)一般、DBU 所以才沒過的嗎?

paicheng0111 iT邦大師 5 級 ‧ 2019-06-17 15:32:41 檢舉

應該是arr只有一個維度，所以Ubound()函數出錯才沒過。

ispiration iT邦新手 5 級 ‧ 2019-06-19 15:09:12 檢舉

朋友你好
我後來黃色那一段改成以下方式就可以跑了
wt.Cells(erow, "A").Resize(UBound(arr)) = Application.Transpose(arr)
所以就是設定一維參數就可以過了可是又出現其他的問題

第一，我抓的是一維矩陣維度是1 * 5
但是程式只有抓到4個值最後一個值沒抓到

原本第4個及第5個值的來源儲存格是有函數的但是第4個值有抓到第5個卻沒有

第二資料是抓到了但是排列方式是在A欄一直往下長資料我希望的是一筆資料橫的長5欄第二筆資料放在下一列橫的長5欄以此類推我想應該是wt.cells(erow,"A")的關係所以資料被鎖在A欄，請問這樣如何改呀

登入發表回應

小魚

iT邦大師 1 級 ‧ 2019-06-13 17:06:25

你應該先把需求寫下來,
然後分成多個步驟,
一步一步解決,
所以現在進行到哪一步了?

回應 3
分享
檢舉

ispiration iT邦新手 5 級 ‧ 2019-06-14 16:08:18 檢舉

您好，我參考網路上類似的範例如下

Sub HzWb()
Dim bt As Range, r As Long, c As Long
r = 1 '1 是表頭的行數
c = 7 '7 是表頭的列數
Dim wt As Worksheet
Set wt = ThisWorkbook.Worksheets(1) '將匯總表指定為變數wt
wt.Rows(r + 1 & ":1048576").ClearContents '清除匯總表中原有的資料，只保留表頭
Application.ScreenUpdating = False
Dim FileName As String, sht As Worksheet, wb As Workbook
Dim Erow As Long, fn As String, arr As Variant
FileName = Dir(ThisWorkbook.Path & "*.xlsx")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then '判斷檔案是否為匯總資料的活頁簿
Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1 '取得匯總表中第一條空行行號
fn = ThisWorkbook.Path & "" & FileName '將第1個要匯總的活頁簿名稱指定為變數fn
Set wb = GetObject(fn) '將變數fn 代表的活頁簿物件指定為變數wb
Set sht = wb.Worksheets(1) '將要匯總的工作表指定為變數sht
'將工作表中要匯總的記錄保存在陣列arr中
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 5))
'將陣列arr 中的資料寫入工作表
wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
FileName = Dir '用Dir 函數取得其他檔案名，並指定為變數
Loop
Application.ScreenUpdating = True
End Sub

但上述的寫法是資料檔以及彙整檔的欄位與格式都一樣，我的狀況是彙整檔與資料檔欄位格式不一樣，所以程式跑到arr這一段就error,

小魚 iT邦大師 1 級 ‧ 2019-06-14 16:34:54 檢舉

可以下中斷點跟逐步偵錯(好像是F8吧),
去找看看問題出在哪裡.

ispiration iT邦新手 5 級 ‧ 2019-06-14 17:15:05 檢舉

以下是我改寫的部分
Sub test2()
Dim bt as Range, r as Long, c as Long
r=1 ' 表頭的行數
c=5 '表頭的列數

Dim wt as Worksheet
Set wt = ThisWorkbook.Worsheets(3) '將彙整表指定為變數wt
wt.Rows(r+1 & ":1048576").ClearContents '清除彙總表原有資料

Application.ScreenUpdating = False
Dim Filename as String, sht as Worksheet, wb as Workbook
Dim erow as Long, fn as String, arr as Variant
Filename = Dir(Thisworkbook.Path & "*.xls")

Do While Filename <> ""
erow = wt.Range("A1").CurrentRegion.Rows.Count + 1
fn = Thisworkbook.path & "" & Filename
set wb = getobject(fn)
set sht = wb.worksheets(1)
arr = sht.Range("D13, D12, D14, F8, F9")
wt.cells(erow, "A").resize(ubound(arr,1),ubound(arr,2)) = arr
wb.close False
end if
Filename = Dir
Loop
Application.Screenupdating = True
End Sub

執行到arr那一行就掛掉，我的寫法是arr是由來源檔案中的D13 D12 D14 F8 F9等5個儲存格組成，再把arr寫到彙整檔的A1 ~ A5，第二個檔案則是B1~B5以此類推，我估計我改的arr寫法應該是有錯，不知要如何改才會對?惠請不吝指教

登入發表回應