返回列表 上一主題 發帖

[發問] 查詢資料並建立樹狀資料

[發問] 查詢資料並建立樹狀資料

各位先進

我想將
01.PNG
2021-7-4 11:35
資料按下按鈕

就去查詢
02.PNG
2021-7-4 11:35
03.PNG
2021-7-4 11:35
兩個工作表

並將結果以樹狀資料方式呈獻
04.PNG
2021-7-4 11:35


查詢項目會有重複,都要列出

"查詢"工作表零件可能會超過10項

"結果"的項目排序須跟"查詢"相同

樹狀資料建立.tar (17 KB)

本帖最後由 singo1232001 於 2021-7-4 15:40 編輯

回復 1# qaqa3296

補充 問題中 原始結果範例的AA007 好像有異常 請確認一下

樹狀資料建立 v1.zip (27.25 KB)

TOP

回復 2# singo1232001

感謝回復,也發現我打範例時,看錯建立錯誤資料的問題

一直以來都是一直人工複製貼上,真的很容易出錯

資料正確太感謝了

TOP

回復 1# qaqa3296

請測試看看,謝謝。

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

TOP

回復 4# samwang


感謝回復

測試後

有時會少列前兩項目(實際用1000多筆資料時會出現,不清楚哪邊出問題可能查詢內的資料有問題?)

有時會出錯,但我看不出哪邊有問題?

尋找的項目太少?

放上出錯的檔案

樹狀資料建立V3.tar (32.5 KB)

TOP

回復 5# qaqa3296

資料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([資料!A1], [資料!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

TOP

回復 6# samwang

功能正常了

感謝samwang提供其他寫法給大家學習

TOP

        靜思自在 : 君子如水,隨方就圓,無處不自在。
返回列表 上一主題