查詢資料並建立樹狀資料
各位先進我想將[attach]33495[/attach]資料按下按鈕
就去查詢[attach]33496[/attach][attach]33497[/attach]兩個工作表
並將結果以樹狀資料方式呈獻[attach]33498[/attach]
查詢項目會有重複，都要列出
"查詢"工作表零件可能會超過10項
"結果"的項目排序須跟"查詢"相同 [i=s] 本帖最後由 singo1232001 於 2021-7-4 15:40 編輯 [/i]
[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115593&ptid=23201]1#[/url] [i]qaqa3296[/i] [/b]
補充 問題中 原始結果範例的AA007 好像有異常 請確認一下 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115596&ptid=23201]2#[/url] [i]singo1232001[/i] [/b]
感謝回復，也發現我打範例時，看錯建立錯誤資料的問題
一直以來都是一直人工複製貼上，真的很容易出錯
資料正確太感謝了 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115593&ptid=23201]1#[/url] [i]qaqa3296[/i] [/b]
請測試看看，謝謝。
Sub test()
Dim Arr, Ar, Brr(1 To 10000, 1 To 4), xD, T, i&, j%, n%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([查詢!K1], [查詢!A65536].End(3))
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) <> "" Then Ar = Ar & "," & Arr(i, j)
Next
xD(Arr(i, 1) & "") = Mid(Ar, 2): Ar = ""
Next
Arr = Range([查詢2!B1], [查詢2!A65536].End(3))
For i = 2 To UBound(Arr): xD(Arr(i, 1) & "") = Arr(i, 2): Next
Arr = Range([資料!A3], [資料!B65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): n = n + 1
If xD.Exists(T & "") Then
Brr(n, 1) = T: Brr(n, 2) = Arr(i, 2)
Ar = Split(xD(T & ""), ",")
For j = 0 To UBound(Ar)
n = n + 1: Brr(n, 3) = Ar(j)
Brr(n, 4) = xD(Brr(n, 3) & "")
Next
Else
Brr(n, 1) = T: Brr(n, 2) = Arr(i, 2)
End If
Next
Sheets("結果").Range("A2").Resize(n, 4) = Brr
End Sub [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115611&ptid=23201]4#[/url] [i]samwang[/i] [/b]
感謝回復
測試後
有時會少列前兩項目(實際用1000多筆資料時會出現，不清楚哪邊出問題可能查詢內的資料有問題?)
有時會出錯，但我看不出哪邊有問題?
尋找的項目太少?
放上出錯的檔案 [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115653&ptid=23201]5#[/url] [i]qaqa3296[/i] [/b]
資料sheets的資料位置與原來檔案的位置不一樣，修改如下，請再測試看看，謝謝。
Sub test2()
Dim Arr, Ar, Brr(1 To 10000, 1 To 4), xD, T, i&, j%, n%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([查詢!K1], [查詢!A65536].End(3))
For i = 2 To UBound(Arr)
For j = 2 To UBound(Arr, 2)
If Arr(i, j) <> "" Then Ar = Ar & "," & Arr(i, j)
Next
xD(Arr(i, 1) & "") = Mid(Ar, 2): Ar = ""
Next
Arr = Range([查詢2!B1], [查詢2!A65536].End(3))
For i = 2 To UBound(Arr): xD(Arr(i, 1) & "") = Arr(i, 2): Next
Arr = Range([資料!A[color=Red]1[/color]], [資料!B65536].End(3))
For i = 2 To UBound(Arr)
T = Arr(i, 1): n = n + 1
If xD.Exists(T & "") Then
Brr(n, 1) = T: Brr(n, 2) = Arr(i, 2)
Ar = Split(xD(T & ""), ",")
For j = 0 To UBound(Ar)
n = n + 1: Brr(n, 3) = Ar(j)
Brr(n, 4) = xD(Brr(n, 3) & "")
Next
Else
Brr(n, 1) = T: Brr(n, 2) = Arr(i, 2)
End If
Next
Sheets("結果").Range("A2").Resize(n, 4) = Brr
End Sub [b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=115654&ptid=23201]6#[/url] [i]samwang[/i] [/b]
功能正常了
感謝samwang提供其他寫法給大家學習 謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教
執行前:
[attach]36494[/attach]
執行結果:
[attach]36495[/attach]
Option Explicit
Sub TEST_1()
Dim Brr, Crr(1 To 100, 1 To 4), Y, T$, R&, i&, j%, Sh(4)
Set Y = CreateObject("Scripting.Dictionary")
For i = 1 To 4: Set Sh(i) = Sheets(i): Next
Brr = Range(Sh(2).[K2], Sh(2).[A65536].End(3))
For i = 1 To UBound(Brr): Y(Brr(i, 1)) = i: Next: Sh(2) = Brr
Brr = Range(Sh(3).[B2], Sh(3).[A65536].End(3))
For i = 1 To UBound(Brr): Y(Brr(i, 1) & "") = Brr(i, 2): Next
Brr = Range(Sh(1).[B2], Sh(1).[A65536].End(3))
For i = 1 To UBound(Brr)
R = R + 1: T = Brr(i, 1): Crr(R, 1) = T: Crr(R, 2) = Brr(i, 2)
For j = 2 To 255
If Sh(2)(Y(T), j) = "" Then Exit For Else: R = R + 1
Crr(R, 3) = Sh(2)(Y(T), j): Crr(R, 4) = Y(Crr(R, 3) & "")
Next
Next
Sh(4).[A2].Resize(R, 4) = Crr
Set Y = Nothing: Erase Brr, Crr, Sh
End Sub
頁:
[1]