[發問] 此收尋vba增加萬用字元

die78325

以下是我寫的收尋並列表程式
但希望能夠改變成  M3輸入"張"   就列出有"張"這個的字的
目前是輸入完整全名才會列表....希望各位大大幫忙!^^ 感恩不盡!   


Sub 統一查詢功能()
'關閉顯示
Application.ScreenUpdating = False

Set Name = Sheets("查詢處理區").Range("M3")
Sheets("統一").Select
G = [A65536].End(xlUp).Row
For i = 2 To G
    '如果有一樣 就向左並複製 轉值貼上至查詢區
    If Sheets("統一").Cells(i, 9) = Name Then
    Sheets("統一").Select
    Cells(i, 9).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Selection.Copy
    Sheets("查詢處理區").Select
    c = [A65536].End(xlUp).Row
    Cells(c + 1, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If
Next i
Sheets("查詢處理區").Select
Application.ScreenUpdating = True  '開啟顯示
MsgBox "統一查詢完成"
End Sub

Hsieh

回復 1# die78325


    If InStr(Sheets("統一").Cells(i, 9), Name) > 0 Then

die78325

回復 2# Hsieh


大大  改這條 不是我要的....
我目前本來就可以收尋全名   只是 不能利用其中一個字來去收尋..... 打張 就要顯示有關張的都要出來  
還是感謝大大熱心回應我   請再幫我想想辦法~~~感恩不盡!!

Hsieh

回復 3# die78325


    Instr函數就是傳回某字元位於字串中的位置(與工作表函數FIND相同)
若字串中不包含搜尋字元則傳回0
與下列LIKE運算得到相同效果
If Sheets("統一").Cells(i, 9) Like "*" & Name & "*" Then

die78325

回復 4# Hsieh


    大大  那如果我想要用這程式  然後他跑的過程中 再加一個偵測  如果已經有相同的 就不貼了
該怎麼修改呢  感謝大大.....研究好久了....

kimbal

回復 5# die78325


    你的意思是多於一個條件?
    如  name="張", name2="明"
    找出來的可以是 "張小明" , "張大明", "明小張" 和 "明大張"

1. If (Sheets("統一").Cells(i, 9) Like "*" & Name & "*") and (Sheets("統一").Cells(i, 9) Like "*" & Name2 & "*")  Then
   
2.       ...
   
3.   end if

複製代碼

如果有先後次序的話,     (即找出來的可以是 "張小明" 和 "張大明",沒有 "明小張" 和 "明大張")

1. If (Sheets("統一").Cells(i, 9) Like "*" & Name &"*" & Name2 & "*") Then
   
2.       ...
   
3. end if

複製代碼

或者再簡單一點只要把NAME設定為 "張*明", 就可以得出上面第2部份的效果

Hsieh

回復 5# die78325

1. Sub 統一查詢功能()
   
2. '關閉顯示
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("Scripting.Dictionary")
   
5. Set Name = Sheets("查詢處理區").Range("M3")
   
6. With Sheets("統一")
   
7. G = .[A65536].End(xlUp).Row
   
8. For i = 2 To G
   
9.     If .Cells(i, 9) Like "*" & Name & "*" And IsEmpty(d(.Cells(i, 9).Value)) Then
   
10.     Sheets(1).[A65536].End(xlUp).Offset(1).Resize(, 9) = Cells(i, 1).Resize(, 9).Value
    
11.     d(.Cells(i, 9).Value) = .Cells(i, 9).Value
    
12.     End If
    
13. Next i
    
14. Sheets("查詢處理區").Select
    
15. Application.ScreenUpdating = True  '開啟顯示
    
16. MsgBox "統一查詢完成"
    
17. End Sub

複製代碼

die78325

回復 7# Hsieh


   
沒有 end with
大大可以順便解釋一下嗎 有些代碼不太了解甚麼意思....感謝!

die78325

回復 6# kimbal


    謝謝大大又教我了一招^^~~ 感謝您!!

但我要的意思是 .....假設A工作頁有100筆資料  有20筆 名子包括張的(A頁是會陸續新增資料) 過幾天可能變25筆   
B頁是固定收尋頁(收尋"張"的)  假設B頁是已經有 15筆"張"的   我按下收尋後   他會依循A頁去尋找 "張"的  但找到張要貼過來時  要去看B頁有沒有這一筆了 有的話 就不貼 繼續往下找 沒有 就貼入B頁最下列

Hsieh

1. Sub 統一查詢功能()
   
2. 
   
3. '關閉顯示
   
4. 
   
5. Application.ScreenUpdating = False
   
6. 
   
7. Set d = CreateObject("Scripting.Dictionary")  '創建字典物件
   
8. 
   
9. Name = Sheets("查詢處理區").Range("M3")  '查詢關鍵字
   
10. 
    
11. With Sheets("統一")  '統一工作表區段
    
12. 
    
13. G = .[A65536].End(xlUp).Row   '統一工作表的資料尾
    
14. 
    
15. For i = 2 To G
    
16. 
    
17.     If .Cells(i, 9) Like "*" & Name & "*" And IsEmpty(d(.Cells(i, 9).Value)) Then '字典中沒出現過I欄且包含查詢關鍵字
    
18. 
    
19.     Sheets("查詢處理區").[A65536].End(xlUp).Offset(1).Resize(, 9) = .Cells(i, 1).Resize(, 9).Value  '將A:I欄寫入Sheets("查詢處理區")
    
20. 
    
21.     d(.Cells(i, 9).Value) = .Cells(i, 9).Value  '將I欄內容存入字典
    
22. 
    
23.     End If
    
24. 
    
25. Next i
    
26. End With '結束統一工作表區段敘述
    
27. Sheets("查詢處理區").Select
    
28. 
    
29. Application.ScreenUpdating = True  '開啟顯示
    
30. 
    
31. MsgBox "統一查詢完成"
    
32. 
    
33. End Sub

複製代碼

回復 9# die78325