VBA

 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
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

'Option Explicit

Sub 单元格循环()
    Dim cel As Range
    Dim cel2 As Range
    Dim t As Double
    t = Timer
    [e6:e13] = ""
    For Each cel In Range("a6:a13")
        For Each cel2 In Range("d6:d13")
            If cel.Value = cel2.Value Then
                cel2.Offset(0, 1).Value = cel.Offset(0, 1).Value
                Exit For
            End If
        Next
    Next
    Debug.Print Format(Timer - t, "0.00000000000000s")
End Sub

Sub 数组循环()
    Dim ar, br
    Dim t As Double
    t = Timer
    [e6:e13] = ""
    ar = [a6:b13] 'range("a6:b13")
    br = [d6:e13]

    Dim i, j
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ar)
            If ar(i, 1) = br(j, 1) Then
                br(j, 2) = ar(i, 2)
                Exit For
            End If
        Next j
    Next i

    [d6:e13] = br
    Debug.Print Format(Timer - t, "0.00000000000000s")
End Sub

Sub 字典循环()
    Dim d As Object, kw$
    Set d = CreateObject("Scripting.Dictionary")
    'd.CompareMode = vbTextCompare '不区分大小写
    Dim ar, br
    Dim t As Double
    t = Timer
    [e6:e13] = ""
    ar = [a6:b13] 'range("a6:b13")
    br = [d6:e13]

    Dim i, j
    For i = 1 To UBound(ar)
        d(ar(i, 1)) = ar(i, 2) 'KEY ITEM
    Next i

    For j = 1 To UBound(br)
        br(j, 2) = d(br(j, 1))
    Next j

    [d6:e13] = br
    Debug.Print Format(Timer - t, "0.00000000000000s")
End Sub

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

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
                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

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
            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

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 Not d.exists(ar(i, 1)) Then
            d(ar(i, 1)) = i
        Else
            d(ar(i, 1)) = d(ar(i, 1)) & "," & i
        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

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结果处理
    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