iT邦幫忙

0

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

  • 分享至 

  • xImage

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

看更多先前的討論...收起先前的討論...
麻辣家族論壇二樓GBKEE
http://forum.twbts.com/thread-13094-1-1.html

查詢資料夾內全部Excel名稱,再來用「跨檔案參照」,就可以寫出你想要的程式。
我現在可以把資料夾內的excel檔名稱抓進我建立的excel檔
請問一下跨檔案參照是否就是用Indirect()函數,可是若把案關閉,Indirect出來的結果就會是error 請問這樣如何處理
Indirect()函數確實會有這樣的弊病。
只能改用Lookup()或直接填入該儲存格位置。
因為考量可能遇到的狀況,可能需要寫vba,我把問題具體更新了一下,煩請您再看看
我參考網路上的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那一段就過不去,請問我可以怎麼改,感謝幫忙
以下是我改寫的部分
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 }} |
{{ formatDate(item.duration) }}
直播中

2 個回答

0
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
看更多先前的回應...收起先前的回應...

感謝高手不吝分享,我跑了一下,出現以下的訊息,是我物件名稱設定錯了嗎?再麻煩您有空看一下 謝謝
https://ithelp.ithome.com.tw/upload/images/20190614/20118293BrjvAg9Ddx.png

typo Worsheets -> Worksheets

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

朋友 你好
我試了一下程式 出現以下的訊息 !
是不是因為sheet名稱是(二)一般、DBU 所以才沒過的嗎?
https://ithelp.ithome.com.tw/upload/images/20190617/20118293LnoXMr1UoB.png

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

朋友 你好
我後來黃色那一段改成以下方式就可以跑了
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欄,請問這樣如何改呀

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

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

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

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吧),
去找看看問題出在哪裡.

以下是我改寫的部分
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寫法應該是有錯,不知要如何改才會對?惠請不吝指教

我要發表回答

立即登入回答