{轉貼問題}將多個工作表依不同比對數據將對應的數值填入工作表1的欄位

Andy2483

請問要如用vba的方式將多個工作表依不同比對資料將對應的數值填入工作表1的指定欄位呢?
例:工作表1的A欄資料去比對工作表3.工作表4.工作表7的A欄資料將對應的C欄數值填入工作表1的F欄.G欄.H欄
     工作表1的D欄資料去比對工作表2.工作表5.工作表6的A欄資料將對應的C欄數值填入工作表1的I欄.J欄.K欄
因資料有幾萬筆,不知可以用vba的方式將資料快速填入又不會耗資源而導致電腦一直轉圈圈

後學感覺這是新會員求救的主題!猜測情境並幫忙做範例!
請各位前輩指導!
Sheet_1是結果表:

下載 (267.57 KB)

2022-10-24 14:02

Sheet_3.4.7是來源表:

下載 (252.1 KB)

2022-10-24 14:13

Sheet_2.5.6也是來源表:

下載 (258.21 KB)

2022-10-24 14:11

範例_20221024.zip (896.05 KB)

下載次數: 7

2022-10-24 14:29

singo1232001

回復 1# Andy2483

Sub 執行這個()
Sheets("工作表_1").Range("F:k").ClearContents
test
test2
End Sub

Sub test()
Dim v As String, ve As String
sr = Split("工作表_3,工作表_4,工作表_7", ",")
Set d = CreateObject("scripting.dictionary")
Set s = Sheets("工作表_1")
r = s.Cells(Rows.Count, 1).End(3).Row
For i = 1 To r
    v = s.Cells(i, 1).Value: ve = Left(v, 1)
    If d.exists(ve) = False Then Set d(ve) = CreateObject("scripting.dictionary")
       d(ve)(v) = s.Cells(i, 1).Row
Next
    ReDim ar(1 To r, 0 To 2) As String
    For h = 0 To 2
    Set s = Sheets(sr(h))
    r = s.Cells(Rows.Count, 1).End(3).Row
        For i = 1 To r
        ve = s.Cells(i, 1).Value
        ar(d(Left(ve, 1))(ve), h) = s.Cells(i, 3).Value
        Next
    Next
    Sheets("工作表_1").Cells(1, 6).Resize(r, 3) = ar
End Sub
Sub test2()
Dim v As String, ve As String
sr = Split("工作表_2,工作表_5,工作表_6", ",")
Set d = CreateObject("scripting.dictionary")
Set s = Sheets("工作表_1")
r = s.Cells(Rows.Count, 4).End(3).Row
For i = 1 To r
    v = s.Cells(i, 4).Value: ve = Left(v, 1)
    If d.exists(ve) = False Then Set d(ve) = CreateObject("scripting.dictionary")
       d(ve)(v) = s.Cells(i, 4).Row
Next
    ReDim ar(1 To r, 0 To 2) As String
    For h = 0 To 2
    Set s = Sheets(sr(h))
    r = s.Cells(Rows.Count, 1).End(3).Row
        For i = 1 To r
        ve = s.Cells(i, 1).Value
        ar(d(Left(ve, 1))(ve), h) = s.Cells(i, 3).Value
        Next
    Next
    Sheets("工作表_1").Cells(1, 9).Resize(r, 3) = ar
End Sub

補充一下
1.工作表_1的資料  用字典 製作成 列號對照表  ,d.keys()是值, d.items()是列號
2.字典也是一種類似逐步一一比對資料的概念, 所以避免太大量在字典內找尋比對,所以分兩層,直接用第一個字當作第一層字典(桶分類)判斷字,而第二層就剩比較少了
3.最後把要比對的資料,依照字典給的列號,放入陣列排好

singo1232001

回復 2# singo1232001


    補充
這種做法有個前提
工作表1,A欄的資料 彼此不能有重複,
D欄內的資料也是彼此間不能有重複

那如果比對時 資料有重複怎麼辦
也有其他的做法能解決
也要看是哪一邊重複   去比 還是 被比   還是兩邊都有各自重複

但主要還是要看問題種類
依目前的問題情境下 是沒有重複資料的類型

Andy2483

回復 2# singo1232001

謝謝前輩指導
字典(桶分類)判斷字!有意思喔!想學!
後學還沒研究前輩的回覆!找工作空檔時間!明天繼續學習!
謝謝!

Andy2483

回復 2# singo1232001


    謝謝前輩指導
前輩厲害!
之前有瀏覽這主題:
http://forum.twbts.com/viewthrea ... a=pageD3&page=3
當時都還看不懂,謝謝前輩在此帖指導!
執行時間超短!

下載 (494.23 KB)

2022-10-25 10:10

以下學習到的心得註解一下! 如有冒犯請見諒!
請前輩指正並再指導! 謝謝
Option Explicit
Sub 執行這個()
Dim T
'↑宣告變數
T = Timer
'↑令T是當下時間 @2
Sheets("工作表_1").Range("F:k").ClearContents
'↑清除表_1  "F:k"欄位儲存格內容
Call test
'↑執行副程式 test()
Call test2
'↑執行副程式 test2()

MsgBox Timer - T & " 秒"
'↑跳出提示窗!顯示 最後時間 - 剛剛的 當下時間 @2
End Sub
Sub test()
Dim v As String, ve As String, sr, d, S, r, i, h, rr
'↑宣告變數
sr = Split("工作表_3,工作表_4,工作表_7", ",")  '@1
'↑令 sr是一維陣列!3個將被搜尋的資料表名稱以","符號分個割 倒入sr
'這是要被 工作表_1(以下稱表_1) A欄搜尋取對應值的3個工作表!
Set d = CreateObject("scripting.dictionary")
'↑令d是字典
Set S = Sheets("工作表_1")
'↑令s 是物件 "表_1" 工作表
r = S.Cells(Rows.Count, 1).End(3).Row
'↑令r是表_1 A欄有內容的儲存格最後一列數
For i = 1 To r
'↑設順迴圈從1 到 A欄有內容的儲存格最後一列數
   v = S.Cells(i, 1).Value
   '↑令v是 表_1 的迴圈A欄儲存格值
   ve = Left(v, 1)
   '↑令ve 是 A欄儲存格值的最左邊的字元
   If d.exists(ve) = False Then
   '↑如果d字典裡沒有這個字元的key
      Set d(ve) = CreateObject("scripting.dictionary")
      '↑若條件成立!就將此字元為key,item是一個d字典中的字典
   End If
   d(ve)(v) = S.Cells(i, 1).Row
    '↑令 d字典中的字典 d(ve)倒入 A欄儲存格值為key!儲存格列位為item
Next
ReDim ar(1 To r, 0 To 2) As String
'↑宣告字串ar 陣列的縱向範圍是1 到 表_1 A欄有內容的儲存格最後一列數
'橫向範圍是0 到2
For h = 0 To 2
'↑設外順迴圈從0 到2
   Set S = Sheets(sr(h))
   '↑令s是 被搜尋的資料表 @1
   rr = S.Cells(Rows.Count, 1).End(3).Row
   '↑令rr是 被搜尋表 A欄有內容的儲存格最後一列數
   For i = 1 To rr
   '↑設內順迴圈從1 到被搜表 A欄有內容的儲存格最後一列數
      ve = S.Cells(i, 1).Value
      '↑令ve是被搜表 的迴圈A欄儲存格值(關鍵字)
      ar(d(Left(ve, 1))(ve), h) = S.Cells(i, 3).Value
      '↑以 被搜表關鍵字最左邊字元為key 查察d字典中對應的item字典
      ',這以字首為名(key)的字典中字典,以被搜表關鍵字查察對應的列數(表_1),
      '為ar陣列的列位,h是該關鍵字搜尋到值的指定欄位
      '↑也就是把 被搜表關鍵字搜尋到的值 放到字典記錄的ar陣列列位中
   Next
Next
Sheets("工作表_1").Cells(1, 6).Resize(r, 3) = ar
'↑將 ar陣列的值從表_1的[F1]開始貼入
End Sub
Sub test2()
Dim v As String, ve As String, sr, d, S, r, i, h, rr
'↑宣告變數
sr = Split("工作表_2,工作表_5,工作表_6", ",")
'↑令 sr是一維陣列!3個將被搜尋的資料表名稱以","符號分個割 倒入sr
'這是要被 工作表_1(以下稱表_1) D欄搜尋取對應值的3個工作表!
Set d = CreateObject("scripting.dictionary")
'↑令d是字典
Set S = Sheets("工作表_1")
'↑令s 是物件 表_1 工作表
r = S.Cells(Rows.Count, 4).End(3).Row
'↑令r是表_1 D欄有內容的儲存格最後一列數
For i = 1 To r
'↑設順迴圈從1 到 D欄有內容的儲存格最後一列數
   v = S.Cells(i, 4).Value
   '↑令v是 表_1 的迴圈D欄儲存格值
   ve = Left(v, 1)
   '↑令ve 是 D欄儲存格值的最左邊的字元
   If d.exists(ve) = False Then
   '↑如果d字典裡沒有這個字元的key
      Set d(ve) = CreateObject("scripting.dictionary")
      '↑若條件成立!就將此字元為key,item是一個d字典中的字典
   End If
   d(ve)(v) = S.Cells(i, 4).Row
   '↑令 d字典中的字典 d(ve)倒入 D欄儲存格值為key!儲存格列位為item
Next
ReDim ar(1 To r, 0 To 2) As String
'↑宣告字串ar 陣列的縱向範圍是1 到 表_1 D欄有內容的儲存格最後一列數
'橫向範圍是0 到2
For h = 0 To 2
'↑設外順迴圈從0 到2
   Set S = Sheets(sr(h))
   '↑令s是 被搜尋的資料表 @1
   rr = S.Cells(Rows.Count, 1).End(3).Row
   '↑令rr是 被搜尋表 A欄有內容的儲存格最後一列數
   For i = 1 To rr
   '↑設內順迴圈從1 到被搜表 A欄有內容的儲存格最後一列數
      ve = S.Cells(i, 1).Value
      '↑令ve是被搜表 的迴圈A欄儲存格值(關鍵字)
      ar(d(Left(ve, 1))(ve), h) = S.Cells(i, 3).Value
      '↑以 被搜表關鍵字最左邊字元為key 查察d字典中對應的item字典
      ',這以字首為名(key)的字典中字典,以被搜表關鍵字查察對應的列數(表_1),
      '為ar陣列的列位,h是該關鍵字搜尋到值的指定欄位
      '↑也就是把 被搜表關鍵字搜尋到的值 放到字典記錄的ar陣列列位中
   Next
Next
Sheets("工作表_1").Cells(1, 9).Resize(r, 3) = ar
'↑將 ar陣列的值從表_1的[I1]開始貼入
End Sub

准提部林

Sub TEST_A1()
Dim Arr, Brr, Crr, Sn, T$, xD, R1&, R2&, Rx&, i&, j%, c%
Set xD = CreateObject("scripting.dictionary")
R1 = [工作表_1!A65536].End(xlUp).Row
R2 = [工作表_1!D65536].End(xlUp).Row
Rx = R1:  If R2 > R1 Then Rx = R2
Arr = Sheets("工作表_1").Range("A1:D" & Rx)
For i = 1 To Rx
    If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "/A") = i
    If Arr(i, 4) <> "" Then xD(Arr(i, 4) & "/D") = i
Next i
ReDim Crr(1 To Rx, 1 To 6)
For Each S In Split("工作表_3/工作表_4/工作表_7/工作表_2/工作表_5/工作表_6", "/")
    R1 = Sheets(S & "").[a65536].End(xlUp).Row
    Brr = Sheets(S & "").Range("A1:C" & R1)
    c = c + 1
    T = IIf(c > 3, "/D", "/A")
    For i = 1 To R1
        R2 = xD(Brr(i, 1) & T)
        If R2 > 0 Then Crr(R2, c) = Brr(i, 3)
    Next i
Next S
Sheets("工作表_1").[f1].Resize(Rx, 6) = Crr
End Sub


'===================================

Andy2483

回復 6# 准提部林
謝謝前輩指導!

下載 (477.87 KB)

2022-10-28 16:42

以下學習到的心得註解一下! 請前輩指正並再指導! 謝謝
Option Explicit
Sub TEST_A1()
Dim Arr, Brr, Crr, Sn, T$, xD, R1&, R2&, Rx&, i&, j%, c%, W, S
'↑宣告變數
W = Timer
Set xD = CreateObject("scripting.dictionary")
'↑令xD是字典
R1 = [工作表_1!A65536].End(xlUp).Row
'↑令R1是 表_1 A欄最後一有內容儲存格列數
R2 = [工作表_1!D65536].End(xlUp).Row
'↑令R2是 表_1 A欄最後一有內容儲存格列數
Rx = R1:  If R2 > R1 Then Rx = R2
'↑取A,D兩欄最大列數
Arr = Sheets("工作表_1").Range("A1:D" & Rx)
'↑令Arr是陣列!倒入A,D兩欄之間有內容儲存格最小方正範圍儲存格的值
For i = 1 To Rx
'↑設順迴圈!從1 到 A,D兩欄最大列數
    If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "/A") = i
    '↑如果迴圈列 Arr陣列第1 欄的值不是空字元! 就將該值+"/A"為key,item是迴圈數 '@@
    If Arr(i, 4) <> "" Then xD(Arr(i, 4) & "/D") = i
    '↑如果迴圈列 Arr陣列第4 欄的值不是空字元! 就將該值+"/D"為key,item是迴圈數 '@@
Next i
ReDim Crr(1 To Rx, 1 To 6)
'↑宣告 Crr陣列的範圍!縱向:1到 A,D兩欄最大列數!橫向:1到6欄
For Each S In Split("工作表_3/工作表_4/工作表_7/工作表_2/工作表_5/工作表_6", "/")
'↑設外順迴圈!令S是 陣列裡的一員(陣列:長字串以 "/" 符號分割成6個元素)
    R1 = Sheets(S & "").[a65536].End(xlUp).Row
    '↑令R1是外迴圈 S+空字元字串 指向的工作表A欄有內容的儲存格最後列數
    Brr = Sheets(S & "").Range("A1:C" & R1)
    '↑令Brr是陣列!倒入外迴圈 S+空字元字串 指向的工作表
    '[A1]到C欄有內容的儲存格最後列數儲存格之間!最小方正範圍儲存格的值
    c = c + 1
    '↑令初始值是1的c!開始累加1
    T = IIf(c > 3, "/D", "/A")
    '↑令T :如果c大於3 T是 "/D"字串 !否則T 是 "/A"字串
    For i = 1 To R1
    '↑設內順迴圈!i從1 到 R1
        R2 = xD(Brr(i, 1) & T)
        '↑令R2是(外迴圈Brr陣列裡的第1欄值與 T字串變數組合的字串組)
       '到xD字典查 @@標示處的迴圈數(也是Arr關鍵字所在的列數)
        If R2 > 0 Then Crr(R2, c) = Brr(i, 3)
       '↑如果關鍵字所在的列數有查到!就令Crr陣列的Arr關鍵字列,c累加的欄數
        '是每個Brr陣列裡的內迴圈數列/第3欄的值
    Next i
Next S
Sheets("工作表_1").[f1].Resize(Rx, 6) = Crr
'↑Crr陣列裡的值從 表_1的 [f1]開始貼入
MsgBox Timer - W & " 秒"
End Sub

97forum

回復 5# Andy2483
感謝Andy的詳細說明，這對於剛開始學習VBA語法的新鮮人來說幫助很大，也容易明白用法。

Andy2483

回復 8# 97forum


    謝謝前輩
以前學習一帖前輩們的程式碼,看>查>理解 要花兩天的時間,多貼之後只要一天
自己套用最難!
很高興可以跟前輩們一起研究這門學問
程式碼註解說明也是要考慮論壇立場.分寸...,而且希望沒有誤導!