[發問] 搜尋序號對應的工作表，並將目標帶回搜尋列中

citizen0923

各位前輩好：

關於如何依序搜尋欄位資料(序號)並將目標工作表的欄位代到指定搜尋列的指定位置，小弟不才已經臨摹多筆範例還是不知從何下手~

目標如下:
把預定要搜尋的序號依序key入欄位，如圖：

下載 (46.15 KB)

2015-11-22 20:20

按下 【↓快速序號查詢】後：
則將對應工作表內序號的欄位複製回搜尋的指定欄位，如圖：

下載 (50.77 KB)
按下搜尋後

2015-11-22 20:23

卡關點在於，
1.不知道怎麼判別目標序號的工作表名稱
2.將目標複製回搜尋列的指定欄位非線性的處理方式

詳細目標檔案請參閱附件下載： 1122希望完成樣式(版本10).zip (79.71 KB)

希望完成樣式
下載次數: 9

2015-11-22 20:37

希望各位大大能夠幫忙指點迷津~~有勞前輩費心了謝謝 :Q

GBKEE

回復 1# citizen0923


試試看

1. Option Explicit
   
2. Sub Ex_序號查詢()
   
3.     Dim D As Object, Sh As Worksheet, Rng As Range, x As Variant
   
4.     Set D = CreateObject("scripting.dictionary")   '字典物件
   
5.     For Each Sh In Sheets
   
6.         If Sh.Name <> "查詢" And Sh.Name <> "出貨輸入" Then '目標序號的工作表
   
7.             Set Rng = Sh.Range("a3")
   
8.             Do While Rng <> ""  '序號="" 時不執行迴圈
   
9.                 x = Rng.Offset(, 1).Value  '序號
   
10.                 D(x) = Rng.Resize(, Sh.UsedRange.Columns.Count) '序號所在列的儲存格
    
11.                 Set Rng = Rng.Offset(1) '下一個序號
    
12.             Loop
    
13.         End If
    
14.     Next
    
15.     Set Sh = Sheets("查詢")
    
16.     Set Rng = Sh.Range("a5")
    
17.     Do While Rng.Offset(, 1) <> ""
    
18.         x = D(Rng.Offset(, 1).Value)  '導入 KEY 的項目(內容)
    
19.         Rng.Resize(, Sh.UsedRange.Columns.Count) = Array(x(1, 1), x(1, 2), x(1, 3), x(1, 5), x(1, 6), x(1, 7), x(1, 8))
    
20.         Set Rng = Rng.Offset(1)
    
21.     Loop
    
22. End Sub

複製代碼

citizen0923

G大~抱歉我試不出來耶 看不懂您後來改的程式碼
直上之後會跳出這個錯誤

下載 (49.01 KB)

2015-11-23 11:34

下載 (44.62 KB)

2015-11-23 11:34

我應該要怎麼調整呢~

yen956

諸位大大你好!!
有兩個 For   Next 迴圈
Exit For 在第2個迴圈內,
為何  Exit For 執行完會跳到第1個迴圈?
希望大大能解惑, 謝謝!!

下載 (37.43 KB)

2015-11-24 09:56

1122希望完成樣式.rar (103.1 KB)

下載次數: 3

2015-11-24 09:58

GBKEE

回復 1# yen956

1. Sub 快速序號查詢()
   
2.     Dim D As Object, Sh As Worksheet, fRng As Range, sRng As Range
   
3.     Dim I As Integer, J As Integer, sNum As String, FstAddr As String
   
4.     Set Sh = Sheets("出貨輸入")
   
5.     For I = 5 To Sh.[B5].End(xlDown).Row
   
6.         sNum = Sh.Cells(I, 2)
   
7.         For J = 3 To Sheets.Count
   
8.             Sheets(J).Activate
   
9.             Set sRng = Sheets(J).Range("B3", "B" & [B2].End(xlDown).Row)   '設定被搜尋的Range
   
10.             sRng.Select
    
11.            ' On Error Resume Next
    
12.             Set fRng = sRng.Find(sNum, lookat:=xlWhole)   '在Sheets(J)的sRng中尋找 序號
    
13.             If Not fRng Is Nothing Then    '有找到
    
14.                 Sh.Cells(I, 1) = fRng.Offset(0, -1)   '拷貝相關資料
    
15.                 Sh.Cells(I, 3) = fRng.Offset(0, 1)
    
16.                 fRng.Offset(0, 3).Select
    
17.                 fRng.Offset(0, 3).Resize(1, 4).Copy Sh.Cells(I, 4)
    
18.                 '你給的圖與測試檔有出入, 圖有[出貨/借出日期],而測試檔的[出貨/借出日期]是空的?
    
19.                 GoTo Next1  '拷貝完換下一個序號       '-> 再重新回到第3個工作頁搜尋下一個序號
    
20.                 '********這個VBA Code是以不重覆為準而寫****               
    
21.                 'Else        '可註解掉
    
22.                 ' Exit For   '否則換下一頁繼續查詢
    
23.             End If
    
24.             '沒有找到 會繼續下一個工作業搜尋
    
25.         Next
    
26. Next1:
    
27.     Next
    
28. End Sub

複製代碼

yen956

大大你好, 沒錯, 把 else, exit for 去掉就對了,
exit for 本來就會跳出自己的回圈, 謝謝指教!!

yen956

感謝 GBKEE 版大的指正, 方能完成

1. '每個[序號]在整個WorkBook的第3頁以後, 是否均只出現一次?不會重覆?
   
2. '這個VBA Code是以不重覆為準而寫
   
3. Sub 快速序號查詢()
   
4.     Dim D As Object, Sh As Worksheet, fRng As Range, sRng As Range
   
5.     Dim I As Integer, J As Integer, sNum As String, FstAddr As String
   
6.     Set Sh = Sheets("出貨輸入")
   
7.     For I = 5 To Sh.[B5].End(xlDown).Row
   
8.         sNum = Sh.Cells(I, 2)
   
9.         For J = 3 To Sheets.Count
   
10.             Sheets(J).Activate
    
11.             Set sRng = Sheets(J).Range("B3", "B" & [B2].End(xlDown).Row)   '設定被搜尋的Range
    
12.             sRng.Select
    
13. '            On Error Resume Next
    
14.             Set fRng = sRng.Find(sNum, lookat:=xlWhole)   '在Sheets(J)的sRng中尋找 序號
    
15.             If Not fRng Is Nothing Then    '有找到
    
16.                 Sh.Cells(I, 1) = fRng.Offset(0, -1)   '拷貝相關資料
    
17.                 Sh.Cells(I, 3) = fRng.Offset(0, 1)
    
18.                 fRng.Offset(0, 3).Select
    
19.                 fRng.Offset(0, 3).Resize(1, 4).Copy Sh.Cells(I, 4)
    
20.                 '你給的圖與測試檔有出入, 圖有[出貨/借出日期],而測試檔的[出貨/借出日期]是空的?
    
21.                 GoTo Next1      '拷貝完換下一個序號
    
22.             End If
    
23.         Next
    
24. Next1:
    
25.     Next
    
26.     Sh.Activate
    
27. End Sub

複製代碼

下載 (110.4 KB)

2015-11-24 11:56

citizen0923

感謝 GBKEE 版大跟YEN大鼎力協助~昨天試完後功能完全正常

不過奇怪的是，今天怎麼試都會一直出現"溢位"的訊息，不知道發生甚麼事了，

下載 (35.96 KB)

2015-11-25 21:57

下載 (40.2 KB)

2015-11-25 21:57

附上，出現問題的原始檔~
1125希望完成樣式(版本12).zip (124.45 KB)

下載次數: 3

2015-11-25 21:58

希望能有機會解決了~不勝感激~~