加快 Excel 中大型数据集的循环速度

Question

我有两个数据集需要比较并从中提取匹配项。我有一个来自每个数据集中 5 列的复合键，结束我需要提取的第 6 列。这些列由文本、日期和整数组成。两组都略低于 50 万行。

目前我在表 a 中使用 for 循环并遍历表 b。将行与带有 and 参数的 if 语句进行比较以获得复合键。

Sub ArraySearch()

    Dim Main As Long
    Dim Search As Long
    Dim arrData() As Variant
    Dim arrSource As Variant

    arrData = Sheets("Sheet1").Range("H3:M500000").Value
    arrSource = Sheets("Ark1").Range("A3:H500000").Value

    Main = 1
    Search = 1

    For Main = 1 To UBound(arrSource, 1)

        For Search = 1 To UBound(arrData, 1)

            If arrSource(Main, 3) = arrData(Search, 1) And _
                arrSource(Main, 4) = arrData(Search, 2) And _
                arrSource(Main, 1) = arrData(Search, 3) And _
                arrSource(Main, 2) = arrData(Search, 4) And _
                arrSource(Main, 5) = arrData(Search, 5) _
            Then
                arrSource(Main, 8) = arrData(Search, 6)
                Exit For
            End If

        Next
    Next

    Sheets("Sheet2").Range("A3:H500000") = arrSource

End Sub

到目前为止，最快的方法是将两个表加载到一个数组中并执行内存循环。

这是永远的。我们说的是小时而不是分钟。

有什么方法可以提高速度吗？ 还是我需要使用其他程序？ （将其加载到数据库中并使用 SQL，将 Visual Studio 与普通 VB.net、SSIS 一起使用）

我希望这可以在 VBA 中完成，因此非常感谢任何指针。

编辑

散列 5 列键会提高速度，还是必须迭代的行的共享量造成了延迟？

Answer 1

比较两个列表的最快方法是根据公共键向 Dictionary 添加值。 Dictionary 已针对搜索键进行了优化，并且将根据键更快地返回一个值，然后您可以遍历数组。

Sub DictionarySearch()
    Dim dict
    Dim key As String
    Dim x As Long
    Dim arrData() As Variant
    Dim arrSource As Variant

    Set dict = CreateObject("Scripting.Dictionary")

    arrData = Worksheets("Sheet1").Range("H3:M500000").Value
    arrSource = Worksheets("Ark1").Range("A3:H500000").Value

    For x = 1 To UBound(arrData, 1)
        key = arrData(x, 1) & ":" & arrData(x, 2) & ":" & arrData(x, 3) & ":" & arrData(x, 4) & ":" & arrData(x, 5)
        If Not dict.Exists(key) Then dict.Add key, arrData(x, 6)

    Next

    For x = 1 To UBound(arrSource, 1)
        key = arrSource(x, 3) & ":" & arrSource(x, 4) & ":" & arrSource(x, 1) & ":" & arrSource(x, 2) & ":" & arrSource(x, 5)
        If dict.Exists(key) Then arrSource(x, 8) = dict(key)
    Next

    Sheets("Sheet2").Range("A3:H500000") = arrSource
End Sub

Answer 2

不是一个完整的答案，但值得一试的想法。在 this answer of mine to my own question 中，我使用了一些加速技巧，例如使用 .Value2 而不是默认属性 (.Value) 并将 vbNullString 而不是零长度字符串 ("") 分配给数组的元素找到了它的匹配项，可以减少 Excel 的处理量。也许你可以像this answer 一样使用Heap's algorithm，虽然我不太确定。

Answer 3

欢迎来到性能改进的奇妙世界 :-)

让我解释一下你在做什么： 您正在获取两个数据集，每个数据集包含 500,000 个条目。然后你会遍历它们，像这样：

for every member in dataset1 do
  for every member in dataset2 do
    if condition1 is met, and
    if condition2 is met, and
    if condition3 is met, and
    if condition4 is met, and
    if condition5 is met
    then do something
    end if-loop
  end for-loop (dataset2)
end for-loop (dataset1)

当您计算您正在执行的操作数量时，我们会看到以下内容：

500,000 runs through dataset1
500,000 runs through dataset2
5 (number of conditions to check)
=> 1250,000,000,000 actions, this is enormous!

最重要的是，您正在使用 VBA：VBA 是一种脚本语言，这意味着在您到达这行代码的那一刻，每一行代码都会被翻译成机器语言（如果您要使用另一种语言，那么你可以编译，只翻译一次机器语言，然后执行该机器语言）

如果您想继续使用 VBA，我可以给您两个建议：

1. 如果可能，请尝试使用已排序的数据集
2. 尽量减少检查条件的数量

这将导致这个新算法：

for every member in dataset1 do
  go in dataset2 from the start to the maximum, defined by the first for-loop, and do
    if condition1 is met, then:
      if condition2 is met, then:
        if condition3 is met, then:
          if condition4 is met, then:
            if condition5 is met
            then do something
            end if-loop
          end if-loop
        end if-loop
      end if-loop
    end if-loop
  end for-loop (dataset2)
end for-loop (dataset1)

这种工作方式会减少您的计算机需要执行的操作数量：

500,000 runs through dataset1
log(500,000) runs through dataset2 (it's only browsed until a certain limit)
3 conditions (on average)
=> 500,000 * log(500,000) * 3 = 8,500,000 actions (on average), which is manageable

我希望这对你有意义。在我看来，这里的主要问题是数据集的排序，这将大大提高你的性能！

Answer 4

Excel 需要评估大量数据。 问题是，Excel 是最好的解决方案，还是用 C++ 或 C# 编写应用程序进行比较会更好？因为它们会更快。

但如果您需要在 VBA 中执行此操作，也许此代码可以帮助您。如果它们具有相同的数据，我总是使用它来比较 2 个范围。而且我从来没有遇到过该代码的速度问题，所以也许你可以看看它。

    Sub Start()
    Dim rng1 As Range
    Dim rng2 As Range
    Dim bolNotEqual As Boolean
    Set rng1 = Sheets("Sheet1").Range("H3:M500000").Value
    Set rng2 = arrSource = Sheets("Ark1").Range("A3:H500000").Value

    'Compare the Sheets if both are Equal
    Call CompareWorksheetRanges(rng1, rng2, bolNotEqual)

End Sub



Sub CompareWorksheetRanges(rng1 As Range, rng2 As Range, ByRef bol As Boolean)

Dim r As Long, c As Integer

Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String

Dim rptWB As Workbook, DiffCount As Long

'If one rng is Empty Exit sup
If rng1 Is Nothing Or rng2 Is Nothing Then Exit Sub


    If rng1.Areas.Count > 1 Or rng2.Areas.Count > 1 Then
        MsgBox "Can't compare multiple selections!", _
            vbExclamation, "Compare Worksheet Ranges"
        Exit Sub
    End If

    Application.StatusBar = "Creating the report..."
    'Testing if the Ranges have the Same sice
    Set rptWB = Workbooks.Add

    With rng1
        lr1 = .Rows.Count
        lc1 = .Columns.Count
    End With
    With rng2
        lr2 = .Rows.Count
        lc2 = .Columns.Count
    End With
    maxR = lr1
    maxC = lc1
    If maxR < lr2 Then maxR = lr2
    If maxC < lc2 Then maxC = lc2
    If lr1 <> lr2 Or lc1 <> lc2 Then
        If MsgBox("The two ranges you want to compare are of different size!" & _
            Chr(13) & "Do you want to continue anyway?", _
            vbQuestion + vbYesNo, "Compare Worksheet Ranges") = vbNo Then Exit Sub
    End If

    'End Testing sice




     DiffCount = 0
'Compare the Ranges if same Value
        For c = 1 To maxC
            Application.StatusBar = "Comparing cells " & _
                Format(c / maxC, "0 %") & "..."
            For r = 1 To maxR
                cf1 = ""
                cf2 = ""
                On Error Resume Next
                cf1 = rng1.Cells(r, c).FormulaLocal
                cf2 = rng2.Cells(r, c).FormulaLocal
                On Error GoTo 0
                If cf1 <> cf2 Then
                    DiffCount = DiffCount + 1
                    Cells(r, c).Formula = "'" & cf1 & " <> " & cf2
                End If
            Next r
        Next c

        Application.StatusBar = "Formatting the report..."



        rptWB.Close False

        Set rptWB = Nothing

        If DiffCount = 0 Then
            bol = False
        Else
            bol = True

        End If
        Application.StatusBar = False
        Application.ScreenUpdating = True

    End Sub