我現在遇到一個問題,現在我的資料夾裡有一些excel檔,如圖1,其中一個是評等彙總檔,設有統編,公司名稱,行業別,信用分數,信用評等共5個欄位。我現在要從這資料夾的其他excel檔把這些欄位資料彙整到這個評等資料檔,這些欄位資料的位置,依照檔名包含test1及test2存放在不同的儲存格,例如檔名包含test1者,信用分數及信用評等欄位存放於D3 & D4, 但是檔名包含test2者,信用分數及信用評等欄位則存放在F3 & F4,我想要寫一個VBA把這5個檔案的資料抓到評等彙總檔,請問要如何撰寫,煩請不吝分享,謝謝。
我沒測過,你試試看。
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
朋友 你好
我試了一下程式 出現以下的訊息 !
是不是因為sheet名稱是(二)一般、DBU 所以才沒過的嗎?
應該是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欄,請問這樣如何改呀
你應該先把需求寫下來,
然後分成多個步驟,
一步一步解決,
所以現在進行到哪一步了?
您好,我參考網路上類似的範例如下
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,
可以下中斷點跟逐步偵錯(好像是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寫法應該是有錯,不知要如何改才會對?惠請不吝指教