在大型数据集上执行 MATCH/INDEX

Question

我有一个包含 55.000 行的数据集，其中包含 35.000 个电子邮件地址，其中 31.000 个是唯一的，因此几个用户占据了多行。我需要找到这些用户的行并将它们添加到类对象中。

将电子邮件列加载到数组中并执行 MATCH/INDEX 查找需要 200 秒。目前可以接受，但对于 200-500K 数据集的预期用途来说，速度肯定不够快。

Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer

Dim dict As Dictionary
Set dict = CreateObject("scripting.dictionary")

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Set UserRange = Range(Cells(2, 11), Cells(LastRow, 11))
For Each cell In UserRange
    dict(cell.value) = dict(cell.value) + 1
Next

Debug.Print "Number of users: " & dict.Count

UserArray = Range(Cells(2, 11), Cells(LastRow, 11))
UserArray = WorksheetFunction.Transpose(WorksheetFunction.Transpose(WorksheetFunction.Transpose(UserArray)))

For Each User In dict
    Dim UserIndex() As Variant
    ReDim UserIndex(1 To dict(User))
    For i = 1 To dict(User)
        Row = WorksheetFunction.Match(User, UserArray, 0)
        UserIndex(i) = Row
        UserArray(Row) = Empty
    Next
    For i = LBound(UserIndex) To UBound(UserIndex)
        Debug.Print User, UserIndex(i)
    Next
Next

SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"

我可能会基于源构建一个基于块的索引（每个导入的文件 +-10.000 个条目都有一个 start- 和 endrow），并通过仅查看适当的块来加速它。但也许还有其他方法？

Answer 1

感谢蒂姆，我得到了一个解决方案：

Dim dict As Dictionary
Set dict = CreateObject("scripting.dictionary")

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Set UserRange = Range(Cells(2, 11), Cells(LastRow, 11))
For Each cell In UserRange
    dict(cell.value) = dict(cell.value) + 1
Next

Debug.Print "Number of users: " & dict.Count

t = Timer

For Each User In dict
    Set Profile = New UserProfile
    Profile.Count = dict(User)
    Dim UserIndex() As Variant
    ReDim UserIndex(1 To dict(User))
    For i = 1 To dict(User)
        Row = WorksheetFunction.Match(User, UserRange, 0)
        UserIndex(i) = Row
    Next
    For i = LBound(UserIndex) To UBound(UserIndex)
        Dim Purchase() As Variant
        ReDim Purchase(1 To LastCol) As Variant
        Purchase = Range(Cells(UserIndex(i) + 1, 1), Cells(UserIndex(i) + 1, LastCol))
        Profile.Add Purchase
    Next
Next

Debug.Print "Match/Index loop completed in ", Timer - t

事实证明，在范围而不是数组上进行匹配要快得多。从范围读取而不是在数组上执行 WorksheetFunction.Index 也是如此。这些结果都出乎我的意料，因为我认为读/写工作簿通常会减慢速度。我还在我的 UserProfile 类中的 thePurchase 数组读数中添加了一个 (1 , 以放弃转置。

整个 55K 数据集的分析仅在 23 秒内完成！

Answer 2

这是另一种相当快的方法：

Sub Lister()

    Dim t, i, m, arr, rng, dict As Object, dictDupes As Object, usr, v
    Set dict = CreateObject("scripting.dictionary")
    Set dictDupes = CreateObject("scripting.dictionary")

    Set rng = Range("A1:A500000")
    'create some dummy data (0.5M rows)
    With rng
        .Formula = "=""USER_"" & ROUND(RAND()*5000,0) & ""_"" & ROUND(RAND()*3000,0)"
        .Value = .Value
    End With

    t = Timer

    arr = rng.Value
    For i = 1 To UBound(arr, 1)
        usr = arr(i, 1)
        If Not dict.exists(usr) Then
            dict.Add usr, i
        Else
            If Not dictDupes.exists(usr) Then dictDupes.Add usr, dict(usr)
            dictDupes(usr) = dictDupes(usr) & "|" & i
        End If
    Next i

    For Each usr In dictDupes
        v = dictDupes(usr)
        'Debug.Print "----" & usr & "---"
        'Debug.Print Join(Split(v, "|"), ", ")
    Next usr

    Debug.Print dict.Count, dictDupes.Count
    Debug.Print "Done in", Timer - t

End Sub

在大约 20-25 秒内完成

另一个说明：

如果您想使用 Match，那么将数据留在工作表上比对数组运行 Match 要快得多。

Sub TestMatch()

    Dim t, i, m, arr, rng

    Set rng = Range("A1:A50000")
    With rng
        .Formula = "=ROUND(RAND()*30000,0)"
        .Value = .Value
    End With

    t = Timer
    For i = 1 To 10000
        m = Application.Match(i, rng, 0)
    Next i
    Debug.Print "sheet", Timer - t

    arr = rng.Value
    t = Timer
    For i = 1 To 10000
        arr = rng.Value
        m = Application.Match(i, arr, 0)
    Next i
    Debug.Print "array", Timer - t

End Sub

输出：

sheet          3.644531 
array          131.9453 

所以数组的速度大约是 35 倍。