[發問] 搜尋代號後，尋找對應列數的儲存格

abc9gad2016

想請教版上前輩

如希望能在"尋找sheet"中，查詢工作表1中的任一個代號

查詢後:往右搜尋到有數字的儲存格，再去對應的第二列查所屬的編號

舉例:尋找GV8CX3Y00，往右搜尋會發現在N、R、S欄位有數字
對應到所屬的第二列為MM、QQ、RR

想請教前輩有沒有函數或VBA有辦法執行這樣的結果(抓出某代號第二列對應的編號)
因代號欄跟編號列會到上千項，手動查詢已經快無法負荷 感謝

函數唯一想到的只有IF，搜尋<>""，但抓到後要如何使之對應到第三列
是卡關的步驟

搜尋範例.rar (151.65 KB)

搜尋範例
下載次數: 33

2021-1-22 16:58

軒云熊

回復 1# abc9gad2016
這是參考  jcchiang 大大的寫法 有空看看是不是這樣 感謝

1. Public Sub 尋找相對欄位練習()
   
2. 
   
3.     Arr = [工作表1!A1].CurrentRegion
   
4.     Set xD = CreateObject("Scripting.Dictionary")
   
5.    
   
6.     For Y = 1 To UBound(Arr, 2)
   
7.         xD(Arr(2, Y)) = Y
   
8.     Next Y
   
9.    
   
10.     For X = 3 To UBound(Arr, 1)
    
11.         For Y = 2 To UBound(Arr, 2)
    
12.             If Arr(X, 1) = [尋找!A2] And Arr(X, Y) <> "" Then
    
13.                 E = E + 1
    
14.                 Sheets(2).Cells(2, 1 + E) = Arr(2, xD(Arr(2, Y)))
    
15.             End If
    
16.         Next Y
    
17.     Next X
    
18. 
    
19. End Sub

複製代碼

samwang

回復 1# abc9gad2016

請測試看看，感謝。

Sub tt()
Set xD = CreateObject("Scripting.Dictionary")
T = Sheets("尋找").[A2]
xD(T & "") = ""
Arr = Range([工作表1!T2], [工作表1!A65536].End(3))
For i = 2 To UBound(Arr)
    If xD.Exists(Arr(i, 1) & "") Then
        For j = 2 To 19
            If Arr(i, j) <> "" Then: M = M + 1: Arr(1, M) = Arr(1, j)
        Next
    End If
Next
If M > 0 Then Sheets("尋找").[B2].Resize(1, M) = Arr
End Sub

軒云熊

回復 3# samwang


感謝 samwang 前輩的指導 小弟受益良多  請問  samwang前輩  T & ""  為甚麼要串連空白  & "" 的用意是甚麼
可否說明一下  我不太理解 因為字典不是那麼直觀

samwang

回復 4# 軒云熊


    看了准大版主常使用此方法，字典加入""字串，可以加快執行速度
    如有不對請各位前賢指教，感謝。

samwang

回復 1# abc9gad2016

請測試看看，謝謝。

Sub tt2()
Set xD = CreateObject("Scripting.Dictionary")
Sheets("尋找").[B2:T2] = ""
T = Sheets("尋找").[A2]
xD(T & "") = ""
Arr = Range([工作表1!T2], [工作表1!A65536].End(3))
For i = 2 To UBound(Arr)
    N = xD(Arr(i, 1) & ""): If N = 0 Then GoTo 99
    For j = 2 To 19
        If Arr(i, j) <> "" Then: M = M + 1: Arr(1, M) = Arr(1, j)
    Next
99: Next
If M > 0 Then Sheets("尋找").[B2].Resize(1, M) = Arr
End Sub

hcm19522

https://blog.xuite.net/hcm19522/twblog/589575552

軒云熊

回復 5# samwang

謝謝samwang前輩的回覆 學習了  感謝

abc9gad2016

回復 7# hcm19522


    感謝大大提供函數的解法 感謝!

abc9gad2016

回復  abc9gad2016

請測試看看，謝謝。

Sub tt2()
Set xD = CreateObject("Scripting.Dictionary" ...
samwang 發表於 2021-1-23 10:31

S大不好意思，測試後發現會少列到一項，如圖

下載 (60.13 KB)
pic

2021-1-25 16:19

因對程式較不熟不清楚要如何修改 謝謝