【VBA案例003】模糊查询

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24

Sub 单元格循环()
    Dim i, j, k, irow
    Dim cel As Range
    Dim t As Double
    t = Timer
    Sheets("查询").Range("a6:d65536").ClearContents
    Dim str As String
    str = Sheets("查询").Range("b3")

    k = 5
    With Sheets("数据源")
        For Each cel In .Range("a2:d" & .[a65536].End(3).Row) 'xlup
            'If cel.Value = str Then
            'If InStr(cel.Value, str) > 0 Then
            If cel.Value Like "*" & str & "*" Then
                k = k + 1
                For j = 1 To 4
                    Sheets("查询").Cells(k, j) = cel.Offset(0, j - 1)
                Next
            End If
        Next
    End With
    MsgBox Format(Timer - t, "0.000s")
End Sub

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

Sub 数组循环()
    Dim i, j, k, irow
    Dim cel As Range
    Dim t As Double
    t = Timer
    Sheets("查询").Range("a6:d65536").ClearContents
    Dim str As String
    str = Sheets("查询").Range("b3")

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

    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 1 To UBound(ar)
        'If ar(i, 1) = str Then
        'If InStr(ar(i, 1), str) > 0 Then
        If ar(i, 1) Like "*" & str & "*" Then
            k = k + 1
            For j = 1 To UBound(br, 2)
                br(k, j) = ar(i, j)
            Next j
        End If
    Next i

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

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43

Sub 字典查询()
    Dim i, j, k, irow
    Dim cel As Range
    Dim t As Double
    t = Timer
    Sheets("查询").Range("a6:d65536").ClearContents
    Dim str As String
    str = Sheets("查询").Range("b3")

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

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

    For i = 1 To UBound(ar)
        'If InStr(ar(i, 1), str) > 0 Then
        If ar(i, 1) Like "*" & str & "*" Then
            If Not d.exists(str) Then
                d(str) = i
            Else
                d(str) = d(str) & "," & i
            End If
        End If
    Next i

    Dim tmpAr
    tmpAr = Split(d(str), ",")

    ReDim br(1 To UBound(tmpAr) + 1, 1 To UBound(ar, 2))
    For i = 0 To UBound(tmpAr)
        For j = 1 To UBound(ar, 2)
            br(i + 1, j) = ar(tmpAr(i), j)
        Next j
    Next i

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

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30

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

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

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