【VBA案例003】模糊查询

归档779

审技265 程技242 投技146 财技57 税技47 法技11 食技7 书技4

776 字

4 分钟

【VBA案例003】模糊查询

2023-10-23

程技

VBA

浏览量加载中...

大家好，模糊查询，在平时工作中会经常遇到。

本期呢，会将模糊查询的两个最常用的方法分享给大家。

1、instr函数 2、like运算符

在开始之前，我建议先把上一期的【VBA案例002】一对多查询看一遍。因为本次内容是基于上次的文件衍生出来的。并且代码也大同小异。

先附上VBA代码，详细内容，请看文章最后的视频哦！~

方法一：#

1
Sub 单元格循环()
2
    Dim i, j, k, irow
3
    Dim cel As Range
4
    Dim t As Double
5
    t = Timer
6
    Sheets("查询").Range("a6:d65536").ClearContents
7
    Dim str As String
8
    str = Sheets("查询").Range("b3")
9

10
    k = 5
11
    With Sheets("数据源")
12
        For Each cel In .Range("a2:d" & .[a65536].End(3).Row) 'xlup
13
            'If cel.Value = str Then
14
            'If InStr(cel.Value, str) > 0 Then
15
            If cel.Value Like "*" & str & "*" Then
16
                k = k + 1
17
                For j = 1 To 4
18
                    Sheets("查询").Cells(k, j) = cel.Offset(0, j - 1)
19
                Next
20
            End If
21
        Next
22
    End With
23
    MsgBox Format(Timer - t, "0.000s")
24
End Sub

方法二：#

1
Sub 数组循环()
2
    Dim i, j, k, irow
3
    Dim cel As Range
4
    Dim t As Double
5
    t = Timer
6
    Sheets("查询").Range("a6:d65536").ClearContents
7
    Dim str As String
8
    str = Sheets("查询").Range("b3")
9

10
    Dim ar, br() 'ar 数据源 ,br 结果
11
    With Sheets("数据源")
12
        irow = .[a65536].End(3).Row
13
        ar = .Range("a2:d" & irow)
14
    End With
15

16
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
17
    For i = 1 To UBound(ar)
18
        'If ar(i, 1) = str Then
19
        'If InStr(ar(i, 1), str) > 0 Then
20
        If ar(i, 1) Like "*" & str & "*" Then
21
            k = k + 1
22
            For j = 1 To UBound(br, 2)
23
                br(k, j) = ar(i, j)
24
            Next j
25
        End If
26
    Next i
27

28
    Sheets("查询").Range("a6").Resize(k, UBound(br, 2)) = br
29
    MsgBox Format(Timer - t, "0.000s")
30
End Sub

方法三：#

1
Sub 字典查询()
2
    Dim i, j, k, irow
3
    Dim cel As Range
4
    Dim t As Double
5
    t = Timer
6
    Sheets("查询").Range("a6:d65536").ClearContents
7
    Dim str As String
8
    str = Sheets("查询").Range("b3")
9

10
    Dim ar, br() 'ar 数据源 ,br 结果
11
    With Sheets("数据源")
12
        irow = .[a65536].End(3).Row
13
        ar = .Range("a2:d" & irow)
14
    End With
15

16
    Dim d As Object, kw$
17
    Set d = CreateObject("Scripting.Dictionary")
18
    'd.CompareMode = vbTextCompare '不区分大小写
19

20
    For i = 1 To UBound(ar)
21
        'If InStr(ar(i, 1), str) > 0 Then
22
        If ar(i, 1) Like "*" & str & "*" Then
23
            If Not d.exists(str) Then
24
                d(str) = i
25
            Else
26
                d(str) = d(str) & "," & i
27
            End If
28
        End If
29
    Next i
30

31
    Dim tmpAr
32
    tmpAr = Split(d(str), ",")
33

34
    ReDim br(1 To UBound(tmpAr) + 1, 1 To UBound(ar, 2))
35
    For i = 0 To UBound(tmpAr)
36
        For j = 1 To UBound(ar, 2)
37
            br(i + 1, j) = ar(tmpAr(i), j)
38
        Next j
39
    Next i
40

41
    Sheets("查询").Range("a6").Resize(UBound(br), UBound(br, 2)) = br
42
    MsgBox Format(Timer - t, "0.000s")
43
End Sub

方法四：#

1
Sub SQL查询()
2
    '定义变量
3
    Dim cnn, rst, SQL$
4
    Dim i, j, k
5
    Set cnn = CreateObject("adodb.connection") '创建数据库连接
6
    Set rst = CreateObject("adodb.recordset") '创建一个数据集保存数据
7
    Dim t As Double
8
    t = Timer
9
    '设置数据库连接
10
    If Val(Application.Version) < 12 Then
11
        cnn.Open "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties='Excel 8.0;HDR=yes';Data Source=" & ThisWorkbook.FullName
12
    Else
13
        cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source=" & ThisWorkbook.FullName
14
    End If
15

16
    '设置SQL语句
17
    'SQL = "SELECT * FROM [数据源$a1:d100] WHERE 班级='" & Sheets("查询").[B3] & "'"
18
    'SQL = "SELECT * FROM [数据源$a1:d100] WHERE instr(班级,'" & Sheets("查询").[B3] & "')>0"
19
    SQL = "SELECT * FROM [数据源$a1:d100] WHERE 班级 like '" & Sheets("查询").[B3] & "%'"
20
    'SQL结果处理
21
    Set rst = cnn.Execute(SQL)
22

23
    Sheets("查询").Range("a6:d65536").ClearContents '清理保存数据的区域
24
    Sheets("查询").Range("a6").CopyFromRecordset rst '结果输出（不带表头）
25
    MsgBox Format(Timer - t, "0.000s")
26
    rst.Close
27
    cnn.Close '关闭数据库连接
28
    Set rst = Nothing
29
    Set cnn = Nothing '将cnn从内存中删除
30
End Sub