[發問] 比對輸入的資料，並篩選至各對應資料行

請問我要篩選出各對應資料後分別填入代號
鍵入需要查詢的字碼後，再比對[C/D/E行]分類，並列出其符合的字碼
1.比對[A行]並在[G行]列出相符[C行]的字碼，但排除[E行]的字碼
2.比對[A行]並在[D行]列出相符[I行]的字碼
3.[A行]比對[C/D/E行]的字碼，在[G行]列出不相符的字碼

以上三種比對有點雜，有點想不通
再請站上的前輩們可以幫忙看看
感謝~

比對用.rar (36.37 KB)

樓主熱帖

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

2^#

發表於 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

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

3^#

發表於 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

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1446
主題: 40
精華: 0
積分: 1470
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-10-21

4^#

發表於 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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP