[發問] 模糊查詢方式

tsuan

想請教諸位先進:

我希望可以在附件查詢內B1 輸入欲查詢公司 或 F2 輸入欲查詢人員時 可以在下方抓到聯絡人頁內之相關資料。
且希望查詢方式可設定為"包含"查詢"資料"即可。
希望先進可指導

聯絡人查詢.rar (4.73 KB)

下載次數: 21

2012-12-14 10:14

die78325

回復 1# tsuan


    聯絡人查詢die78325.rar (14.87 KB)

下載次數: 31

2012-12-14 12:59

附件內我只做了 姓名查詢   F1
公司也是這樣做 只是裡面稍微簡單改一下  !  
有問題在發問!

GBKEE

回復 1# tsuan
程式碼:   複製貼上在 [查詢]工作表的模組

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)  '[查詢]工作表的 ( 修改儲存格 ) 觸發事件
   
3.     If Target.Address(0, 0) = "B1" Or Target.Address(0, 0) = "F1" Then
   
4.         Application.EnableEvents = False                            '停止:觸發事件
   
5.         'EnableEvents 屬性 如果指定物件能觸發事件，則本屬性為 True。讀/寫 Boolean。
   
6.         Range("A3").CurrentRegion.Offset(1) = ""                    '清除舊有查詢資料
   
7.         With Sheets("聯絡人")
   
8.             .AutoFilterMode = False
   
9.             'AutoFilterMode 屬性 如果目前在工作表上顯示有 [自動篩選] 下拉箭號，則此屬性為 True。
   
10.             '該屬性與 FilterMode 屬性互相獨立。讀/寫 Boolean。
    
11.             .Range("A1").AutoFilter 1, "*" & [B1] & "*"
    
12.             '[自動篩選] 第一欄 準則字串:   "*" & [B1] & "*"
    
13.             
    
14.             .Range("A1").AutoFilter 2, "*" & [F1] & "*"
    
15.             '[自動篩選] 第二欄 準則字串:   "*" & [F1] & "*"
    
16.             
    
17.             .UsedRange.Offset(1).Copy [A4]                          '複製資料
    
18.             .AutoFilterMode = False
    
19.         End With
    
20.         Application.EnableEvents = True
    
21.     End If
    
22. End Sub

複製代碼

GBKEE

回復 2# die78325
查詢功能() :加上公司查詢
Name 是VBA使用的關鍵字  變數,程序名稱要避免使用

1. Option Explicit
   
2. Sub 查詢功能()
   
3.     Dim 人員 As Range, 公司 As Range, I As Integer
   
4.     Application.ScreenUpdating = False  '關閉顯示
   
5.     With Sheets("查詢")
   
6.         Set 公司 = .Range("B1")
   
7.         Set 人員 = .Range("F1")
   
8.         .Range("A4:A" & .[a4].End(xlDown).Row).EntireRow = ""
   
9.     End With
   
10.     With Sheets("聯絡人")
    
11.         For I = 2 To .[B65536].End(xlUp).Row
    
12.             If .Cells(I, 1) Like "*" & 公司 & "*" And .Cells(I, 2) Like "*" & 人員 & "*" Then '萬用字元收尋
    
13.                 Sheets("聯絡人").Range("A" & I & ":J" & I).Copy
    
14.                 With Sheets("查詢")
    
15.                     .Cells(.[a65536].End(xlUp).Row + 1, 1).PasteSpecial Paste:=xlPasteValues
    
16.                 End With
    
17.             End If
    
18.         Next I
    
19.     End With
    
20.     Sheets("查詢").Activate
    
21.     [F1].Select
    
22.     Application.ScreenUpdating = True  '開啟顯示
    
23. End Sub

複製代碼

tsuan

感謝 die78325  及 GBKEE 兩位
愉快使用中，也正在學習兩位方式中。

Hsieh

回復 5# tsuan
參數查詢

下載 (1.2 MB)

2012-12-16 15:52

yanto913

[b]回復 [url=http://forum.twbts.com/redirect.php?goto=findpost&pid=48426&ptid=8577]6#[/url] [i]Hsieh[/i] [/b]


    第二層用姓名不會有作用，不知道小弟我哪裡設錯了??

Hsieh

回復 7# yanto913


    此問題回復的重點在說明SQL查詢加入參數的模糊查詢語法
至於你所謂第二層查詢，所指為何?
多準則查詢要看條件成立的準則
若第一條件與第二條件要同時成立，則準則應該放在同一列，

下載 (33.83 KB)

2012-12-29 15:13

若準則只要其中一項成立，那麼2個準則條件式就不能在同一列

下載 (33.96 KB)

2012-12-29 15:12

yanto913

請各位先進幫忙，設定後無法篩選

GBKEE

回復 9# yanto913

1. Option Explicit
   
2. Sub 查詢功能()
   
3.     Dim Ex_Name As String, Ex_公司
   
4.     'Name 是VBA的關鍵字請避免使用
   
5.     '關閉顯示
   
6.     Application.ScreenUpdating = False
   
7.     With Sheets("查詢")
   
8.         Ex_Name = .Range("F1")   '姓名
   
9.         Ex_公司 = .Range("B1")   '公司
   
10.       '  .UsedRange.Offset(2).Clear  '清除舊有的查詢
    
11.     End With
    
12.     With Sheets("聯絡人")
    
13.         G = .[B65536].End(xlUp).Row
    
14.             For I = 2 To G
    
15.                 '萬用字元收尋
    
16.               '  If .Cells(I, 2) Like "*" & Ex_Name & "*" Then '只查姓名
    
17.                 If .Cells(I, 1) Like "*" & Ex_公司 & "*" And .Cells(I, 2) Like "*" & Ex_Name & "*" Then '查 姓名及公司
    
18.                 'If .Cells(I, 1) Like "*" & Ex_公司 & "*" Or .Cells(I, 2) Like "*" & Ex_Name & "*" Then '可查姓名 Or 公司
    
19.                     .Range(.Cells(I, 1), .Cells(I, 10)).Copy
    
20.                     c = Sheets("查詢").[a65536].End(xlUp).Row
    
21.                     Sheets("查詢").Cells(c + 1, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    
22.                     :=False, Transpose:=False
    
23.                 End If
    
24.             Next I
    
25.     End With
    
26.     Application.ScreenUpdating = True  '開啟顯示
    
27. End Sub

複製代碼