標題: [發問] 比對輸入的資料，並篩選至各對應資料行 [打印本頁]

---

作者: jackson7015    時間: 2021-9-9 15:06     標題: 比對輸入的資料，並篩選至各對應資料行

請問我要篩選出各對應資料後分別填入代號
鍵入需要查詢的字碼後，再比對[C/D/E行]分類，並列出其符合的字碼
1.比對[A行]並在[G行]列出相符[C行]的字碼，但排除[E行]的字碼
2.比對[A行]並在[D行]列出相符[I行]的字碼
3.[A行]比對[C/D/E行]的字碼，在[G行]列出不相符的字碼
[attach]33998[/attach]
以上三種比對有點雜，有點想不通
再請站上的前輩們可以幫忙看看
感謝~
[attach]33999[/attach]

---

作者: samwang    時間: 2021-9-10 07:52

回復 1# jackson7015

請測試看看，謝謝

Sub test()
Dim Arr, Brr(), xD, xD1, T$, AR%, BR%, DR%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
R = Columns("C:E").Find("*", SearchDirection:=xlPrevious).Row
Arr = Range("C1:E" & R)
For j = 1 To 3: For i = 2 To UBound(Arr)
T = Arr(i, j): xD(T & "_" & j) = 1: xD1(T) = 1
Next i: Next j
Arr = Range([a1], [a65536].End(3))
ReDim Brr(1 To UBound(Arr), 1 To 3)
For i = 2 To UBound(Arr)
    T = Arr(i, 1): N = xD1(T)
    If N <> 1 Then DR = DR + 1: Brr(DR, 1) = T: GoTo 99
    For j = 1 To 2
        If xD.Exists(T & "_" & j) Then
            If j = 1 Then
                If Not xD.Exists(T & "_3") Then
                    AR = AR + 1: Brr(AR, 2) = T
                End If
            Else
                BR = BR + 1: Brr(BR, 3) = T
            End If
        End If
    Next
99: Next
Range("g2").Resize(UBound(Brr), 3) = Brr
End Sub

---

作者: 准提部林    時間: 2021-9-11 11:26

Sub TEST_A1()
Dim Arr, Brr, xD, T$, i&, j%, N&(4)
Set xD = CreateObject("Scripting.Dictionary")
For j = 1 To 3
    Arr = Range(Cells(1, j + 2), Cells(Rows.Count, j + 2).End(xlUp))
    For i = 2 To UBound(Arr)
        If Arr(i, 1) <> "" Then xD(Arr(i, 1) & "") = j
    Next i
Next j
'----------------------------------
Arr = Range([a1], Cells(Rows.Count, 1).End(xlUp))
ReDim Brr(1 To UBound(Arr), 1 To 4)
For i = 2 To UBound(Arr)
    T = Arr(i, 1): If T = "" Then GoTo i01
    j = xD(T) + 1: N(j) = N(j) + 1
    Brr(N(j), j) = T
i01: Next i
[g2].Resize(UBound(Brr), 3) = Brr
End Sub

---

作者: Andy2483    時間: 2023-1-6 14:40

回復 1# jackson7015


    謝謝前輩發表此主題與範例
謝謝兩位前輩指導
後學藉此帖練習字典與陣列

Option Explicit
Sub TEST_20230106_1()
Dim Brr, i&, x, Y, j&, Lac&
Set Y = CreateObject("Scripting.Dictionary")
Lac = Cells.SpecialCells(xlLastCell).Row
Brr = Range([A2], Cells(Lac, "E"))
For j = 1 To 5
   If j = 2 Then GoTo Spa
   Set Y(j) = CreateObject("Scripting.Dictionary")
   For i = 1 To UBound(Brr)
      If Brr(i, j) = "" Then GoTo Spa
      Y(j)(Brr(i, j)) = i
   Next
Spa:
Next
ReDim Brr(1 To Y(1).Count, 1 To 3)
For Each x In Y(1).KEYS
   If Y(3)(x) & Y(4)(x) & Y(5)(x) = "" Then
      Y("G") = Y("G") + 1
      Brr(Y("G"), 1) = x
      ElseIf Y(3)(x) > 0 And Y(5)(x) = "" Then
         Y("H") = Y("H") + 1
         Brr(Y("H"), 2) = x
      ElseIf Y(4)(x) > 0 Then
         Y("I") = Y("I") + 1
         Brr(Y("I"), 3) = x
   End If
Next
Range([G2], Cells(Lac, "I")).ClearContents
[G2].Resize(UBound(Brr), 3) = Brr
Set Y = Nothing
End Sub

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)