麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 搜尋代號後，尋找對應列數的儲存格 [打印本頁]

作者: abc9gad2016 時間: 2021-1-22 16:59 標題: 搜尋代號後，尋找對應列數的儲存格

想請教版上前輩

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

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

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

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

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

[attach]32992[/attach]

作者: 軒云熊 時間: 2021-1-22 21:20

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

Public Sub 尋找相對欄位練習()
Arr = [工作表1!A1].CurrentRegion
Set xD = CreateObject("Scripting.Dictionary")
For Y = 1 To UBound(Arr, 2)
xD(Arr(2, Y)) = Y
Next Y
For X = 3 To UBound(Arr, 1)
For Y = 2 To UBound(Arr, 2)
If Arr(X, 1) = [尋找!A2] And Arr(X, Y) <> "" Then
E = E + 1
Sheets(2).Cells(2, 1 + E) = Arr(2, xD(Arr(2, Y)))
End If
Next Y
Next X
End Sub

複製代碼

作者: samwang 時間: 2021-1-22 23:27

回復 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

作者: 軒云熊 時間: 2021-1-23 01:32

回復 3# samwang

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

作者: samwang 時間: 2021-1-23 09:36

回復 4# 軒云熊

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

作者: samwang 時間: 2021-1-23 10:31

回復 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 時間: 2021-1-23 11:32

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

作者: 軒云熊 時間: 2021-1-24 19:01

回復 5# samwang

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

作者: abc9gad2016 時間: 2021-1-25 13:41

回復 7# hcm19522

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

作者: abc9gad2016 時間: 2021-1-25 16:19

回復 abc9gad2016

請測試看看，謝謝。

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

S大不好意思，測試後發現會少列到一項，如圖[attach]33003[/attach]
因對程式較不熟不清楚要如何修改謝謝

作者: abc9gad2016 時間: 2021-1-25 16:33

本帖最後由 abc9gad2016 於 2021-1-25 16:34 編輯

回復 2# 軒云熊

謝大大~測試成功
另外想請教若表格中多了一些無關的資訊，要改由F7:X24這個範圍尋找F6開始的對應值的話[attach]33004[/attach]
應該要如何修改程式呢謝謝

作者: samwang 時間: 2021-1-25 17:41

回復 10# abc9gad2016

不好意思，少算1欄，請再測試看看，謝謝
  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 20
      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

作者: 軒云熊 時間: 2021-1-25 21:23

本帖最後由軒云熊於 2021-1-25 21:24 編輯

回復 11# abc9gad2016

Public Sub 尋找相對欄位練習()
Application.ScreenUpdating = False
Range(Sheets(2).Cells(2, 2).End(xlToRight), Sheets(2).Cells(2, 2)).ClearContents
Arr = Range(Sheets(1).Cells(Rows.Count, 1).End(xlUp), Sheets(1).Cells(6, 1).End(xlToRight))
Set xD = CreateObject("Scripting.Dictionary")

For Y = 1 To UBound(Arr, 2)
      xD(Arr(1, Y)) = Y
Next Y

For X = 3 To UBound(Arr, 1)
      For Y = 6 To UBound(Arr, 2)
         If Arr(X, 1) = [尋找!A2] And Arr(X, Y) <> "" Then
            E = E + 1
            Sheets(2).Cells(2, 1 + E) = Arr(1, xD(Arr(1, Y)))
         End If
      Next Y
Next X
Application.ScreenUpdating = True
End Sub

建議修改 samwang 大大的位置比較好他的寫法比我的好很多

作者: abc9gad2016 時間: 2021-1-26 09:43

本帖最後由 abc9gad2016 於 2021-1-26 09:46 編輯

回復 13# 軒云熊

還是相當感謝大大分享~

作者: abc9gad2016 時間: 2021-1-26 09:47

回復 abc9gad2016

不好意思，少算1欄，請再測試看看，謝謝
Sub tt2()
Set xD = CreateObject("Sc ...
samwang 發表於 2021-1-25 17:41

感謝大大，昨晚用您的程式碼後稍做修改有成功弄成我要的樣子謝謝
Sub 搜尋()
'
' 搜尋巨集
' 搜尋
''
Worksheets("尋找").Range("B2:V2").ClearContents
Set xD = CreateObject("Scripting.Dictionary")
Sheets("尋找").[F6:X6] = ""
T = Sheets("尋找").[A2]
xD(T & "") = ""
Arr = Range([工作表1!X6], [工作表1!A65536].End(3))
For i = 2 To UBound(Arr)
N = xD(Arr(i, 1) & ""): If N = 0 Then GoTo 99
For J = 6 To 24
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

作者: abc9gad2016 時間: 2021-1-26 10:06

回復 12# samwang

不好意思想再請教S大，如果依照這份表格我想搜尋範圍為J64:BR64
不知道我哪邊修改錯還請指點，無法執行出要的結果謝謝
[attach]33005[/attach]

作者: 准提部林 時間: 2021-1-26 10:10

Sub FindData()
Dim xR As Range, xA As Range, xF As Range, j%
Set xR = [尋找!a2]
xR(1, 2).Resize(1, 200) = ""
Set xA = Sheets("工作表1").UsedRange
Set xF = xA.Columns(1).Find(xR, Lookat:=xlWhole)
If xR = "" Or xF Is Nothing Then Exit Sub
For j = 2 To xA.Columns.Count
If xF(1, j) <> "" Then Set xR = xR(1, 2): xR = xA(2, j)
Next j
End Sub

作者: samwang 時間: 2021-1-26 11:07

回復 16# abc9gad2016

請測試看看，謝謝
Sub tt3()
Set xD = CreateObject("Scripting.Dictionary")
Sheets("尋找").[B2].Resize(1, 200) = ""
T = Sheets("尋找").[A2]
xD(T & "") = ""
Arr = Range([工作表1!BR64], [工作表1!A65536].End(3))
For i = 2 To UBound(Arr)
   N = xD(Arr(i, 1) & ""): If N = 0 Then GoTo 99
   For j = 10 To UBound(Arr, 2)
      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

作者: abc9gad2016 時間: 2021-1-26 16:34

回復 18# samwang

感謝大大!測試修改成功，想請問這兩段修改比較多，可以請教是什麼意思嗎謝謝
Sheets("成品").[L2].Resize(1, 200) = ""

For J = 10 To UBound(Arr, 2)

作者: abc9gad2016 時間: 2021-1-26 16:44

回復 17# 准提部林

謝謝版主!

作者: samwang 時間: 2021-1-26 17:39

回復 19# abc9gad2016

Sheets("成品").[L2].Resize(1, 200) = "" --> 清除上一次查詢資料

For J = 10 To UBound(Arr, 2)
-->因為搜尋範圍為J64:BR64
設定範圍Arr = Range([工作表1!BR64], [工作表1!A65536].End(3))
UBound(Arr, 2) Arr最後一欄 BR

作者: abc9gad2016 時間: 2021-1-27 15:15

回復  abc9gad2016

Sheets("成品").[L2].Resize(1, 200) = ""  --> 清除上一次查詢資料

For  ...
samwang 發表於 2021-1-26 17:39

明白了，感謝S大

作者: Andy2483 時間: 2023-11-24 15:26

本帖最後由 Andy2483 於 2023-11-24 15:37 編輯

回復 17# 准提部林

謝謝論壇,謝謝前輩指導
後學藉此帖學習物件(儲存格)的使用,學習到很多知識,以下是心得註解,請前輩再指導

Option Explicit
Sub FindData()
Dim xR As Range, xA As Range, xF As Range, j%
'↑宣告變數:(xR,xA,xF)是儲存格變數,j是短整數
Set xR = [尋找!a2]
'↑令xR變數是"尋找"表的[A2]儲存格
xR(1, 2).Resize(1, 200) = ""
'↑令xR變數右1格儲存格擴展向右200格範圍儲存格值是空字元
Set xA = Sheets("工作表1").UsedRange
'↑令xA變數是 "工作表1"表有使用儲存格擴展最小方正範圍儲存格
Set xF = xA.Columns(1).Find(xR, Lookat:=xlWhole)
'↑令xF變數是 xA變數第1欄以 Range.Find 方法回傳物件(儲存格),
'亦以xR變數尋找 xA變數第1欄裡值全同的儲存格,回傳給xF變數
If xR = "" Or xF Is Nothing Then Exit Sub
'↑如果xR變數值是空字元或xF是無物件? True就結束程式執行
For j = 2 To xA.Columns.Count
'↑設順迴圈!j從2 到 xA變數欄數
If xF(1, j) <> "" Then Set xR = xR(1, 2): xR = xA(2, j)
'↑如果xF變數第1列j變數欄儲存格值不是空的?
'True就令R變數是右1格儲存格,令xR變數是xA變數第2列j變數欄儲存格值
Next j
End Sub
學無止境!
或許真相只有一個,但是找尋真相的方法不只一種
謝謝前輩常用不同的方法指導後學

作者: hcm19522 時間: 2023-11-24 16:05

(輸入編號12057) google網址:https://hcm19522.blogspot.com/

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