【VBA案例002】一对多查询

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
                k = k + 1
15
                For j = 1 To 4
16
                    Sheets("查询").Cells(k, j) = cel.Offset(0, j - 1)
17
                Next
18
            End If
19
        Next
20
    End With
21
    MsgBox Format(Timer - t, "0.000s")
22
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
            k = k + 1
20
            For j = 1 To UBound(br, 2)
21
                br(k, j) = ar(i, j)
22
            Next j
23
        End If
24
    Next i
25

26
    Sheets("查询").Range("a6").Resize(k, UBound(br, 2)) = br
27
    MsgBox Format(Timer - t, "0.000s")
28
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 Not d.exists(ar(i, 1)) Then
22
            d(ar(i, 1)) = i
23
        Else
24
            d(ar(i, 1)) = d(ar(i, 1)) & "," & i
25
        End If
26
    Next i
27

28
    Dim tmpAr
29
    tmpAr = Split(d(str), ",")
30

31
    ReDim br(1 To UBound(tmpAr) + 1, 1 To UBound(ar, 2))
32
    For i = 0 To UBound(tmpAr)
33
        For j = 1 To UBound(ar, 2)
34
            br(i + 1, j) = ar(tmpAr(i), j)
35
        Next j
36
    Next i
37

38
    Sheets("查询").Range("a6").Resize(UBound(br), UBound(br, 2)) = br
39
    MsgBox Format(Timer - t, "0.000s")
40
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

19
    'SQL结果处理
20
    Set rst = cnn.Execute(SQL)
21

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