返回列表 上一主題 發帖

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

本帖最後由 singo1232001 於 2022-10-24 15:37 編輯

回復 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.最後把要比對的資料,依照字典給的列號,放入陣列排好

TOP

本帖最後由 singo1232001 於 2022-10-24 15:50 編輯

回復 2# singo1232001


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

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

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

TOP

        靜思自在 : 靜坐常恩己過、閒談莫論人非。
返回列表 上一主題