返回列表 上一主題 發帖

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

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

以下是我寫的收尋並列表程式
但希望能夠改變成  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

回復 1# die78325


    If InStr(Sheets("統一").Cells(i, 9), Name) > 0 Then
學海無涯_不恥下問

TOP

回復 2# Hsieh


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

TOP

回復 3# die78325


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

TOP

回復 4# Hsieh


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

TOP

本帖最後由 kimbal 於 2012-11-19 22:28 編輯

回復 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部份的效果
懂得發問,答案就會在其中

今日の一秒は  明日にない
http://kimbalko-chi.blogspot.com
http://kimbalko.blogspot.com

TOP

回復 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
複製代碼
學海無涯_不恥下問

TOP

回復 7# Hsieh


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

TOP

回復 6# kimbal


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

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

TOP

  1. Sub 統一查詢功能()

  2. '關閉顯示

  3. Application.ScreenUpdating = False

  4. Set d = CreateObject("Scripting.Dictionary")  '創建字典物件

  5. 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 '字典中沒出現過I欄且包含查詢關鍵字

  10.     Sheets("查詢處理區").[A65536].End(xlUp).Offset(1).Resize(, 9) = .Cells(i, 1).Resize(, 9).Value  '將A:I欄寫入Sheets("查詢處理區")

  11.     d(.Cells(i, 9).Value) = .Cells(i, 9).Value  '將I欄內容存入字典

  12.     End If

  13. Next i
  14. End With '結束統一工作表區段敘述
  15. Sheets("查詢處理區").Select

  16. Application.ScreenUpdating = True  '開啟顯示

  17. MsgBox "統一查詢完成"

  18. End Sub
複製代碼
回復 9# die78325
學海無涯_不恥下問

TOP

        靜思自在 : 有願放在心裡,沒有身體力行,正如耕田不播種,皆是空過因緣。
返回列表 上一主題