☰

如何使嵌套循环更快地在 vba 中查找指令

tag-icon • tag-icon microsoft-excel vba
如何使嵌套循环更快地在 vba 中查找指令

问题描述：循环遍历 excel 最大行数（约 10000000）来查找 instr。找到 instr 后，获取值并将值复制到不同的工作表。每次找到匹配项（即 instr）时，仅复制匹配项的值并将其粘贴到不同的工作表。

问题：我正在使用嵌套循环，我的循环运行缓慢，所以对于 1000 万行，它大约需要 19:37 分钟。我计时了。所以第一个问题是，是否有不同的方法可以做到这一点，或者我如何让它更快而不是 20 分钟，是否有可能在 1 分钟或两分钟内比较 2000 万个字符串（每张表 1000 万行，1000 万个字符串）。这是我当前的代码

  Sub zym()
   Dim x As Long, lastrow As Long, lastrowx As Long, i As Long, ii As Long
   Dim ws As Worksheet, ws2 As Worksheet, b As String
   Dim j As Long

   Set ws = Worksheets("Sheet1")
   Set ws2 = Worksheets("Sheet2")
   Set ws3 = Worksheets("Sheet3")
   j = 1
      T1 = GetTickCount

  lastrow = ws.UsedRange.Rows.Count + 1
  lastrowx = ws2.UsedRange.Rows.Count + 1

   ReDim sheet1array(1 To lastrow)
   ReDim sheet2array(1 To lastrowx)

    For i = LBound(sheet1array) To UBound(sheet1array)
        b = "-" & ws.Range("A" & i) & "-"
      For ii = LBound(sheet2array) To UBound(sheet2array)
        If InStr(1, ws2.Range("A" & ii), b) > 0 Then
        ws3.Range("A" & j) = ws2.Range("A" & ii)
        j = j + 1
        End If

       Next ii
     Next i
    Debug.Print "Array Time = " & (GetTickCount - T1) / 1000#
    Debug.Print "Array Count = " & Format(ii, "#,###")

End Sub

答案1

读取和写入工作表上的单元格会减慢任何宏的速度。以下代码将单元格值复制到数组中并循环遍历这些数组。输出从结果数组分块复制到目标工作表中。
在我的笔记本上，原始代码花费了 56 秒，此代码花费了 3.7 秒：

Sub zym2()
    Dim lastrow As Long, i As Long, j As Long, start As Long
    Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim b As String
    Dim T1 As Long
    Dim arr1, arr2, arr3, c

    Set ws = Worksheets("sh1")
    Set ws2 = Worksheets("sh2")
    Set ws3 = Worksheets("sh3")
    ws3.Columns(1).Clear
    T1 = Timer

    arr1 = Intersect(ws.Columns(1), ws.UsedRange)
    lastrow = UBound(arr1)
    arr2 = ws2.UsedRange
    ReDim arr3(1 To lastrow / 10, 2)   ' initial length is arbitrary

    j = 0
    start = 1
    For i = 1 To lastrow
        b = "-" & arr1(i, 1) & "-"
        For Each c In arr2
            If InStr(1, c, b) > 0 Then
                If j = UBound(arr3) Then
                    ws3.Range(Cells(start, 1), Cells(start - 1 + j, 1)) = arr3
                    start = start + j
                    j = 0
                End If
                j = j + 1
                arr3(j, 1) = c
            End If
        Next c
    Next i
    If j > 0 Then
        ws3.Range(Cells(start, 1), Cells(start - 1 + j, 1)) = arr3
    End If
    Debug.Print "Array Time = " & Format(Timer - T1, "##.0")
    Debug.Print "Array Count = " & Format(start - 1 + j, "#,###")
End Sub

答案2

虽然我已经给出了答案，但我想在这里提出一种完全不同的算法，以便将性能提高另一个数量级。
当扫描 Sheet1 上的“大列表”并搜索 Sheet2 中的匹配项时，一次扫描后，有关成功搜索的信息就会被丢弃。Sheet1 将包含搜索值的重复，当扫描 Sheet2 时，我们可以利用它的频率。

查找唯一搜索值及其频率的方法是使用字典对象。要在 VBA 中使用它，必须在 VBA 编辑器中添加对“Microsoft Scripting”的引用。
第二个假设是输出列表不需要保留输入顺序（因为它无论如何都会排序）。以下代码将在 sheet3 中生成一个输出列表，其中的搜索值按它们在大列表中出现的顺序排列，但所有重复项都在一个块中。计时语句已被注释掉，因为这需要外部类定义。

Sub zym_dict()
' http://superuser.com/questions/976906/how-to-make-nested-loop-faster-to-find-instr-in-vba
' by E/S/P 2015-09-25
' 2nd improvement: use a dictionary object to count unique search items and loop over these
' speed 1:13 vs. array version; 1:186 vs. original (cell) version

    Dim numvalues As Long, i As Long, j As Long, nextresult As Long
    Dim numcompared As Long, numresults As Long
    Dim cnt As Long
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim searchterm As String
    Dim values, arr2, results, c, v
    Dim uniq As New Scripting.Dictionary

    ' Dim mStopWatch As New clsStopWatch

    Set ws1 = Worksheets("sheet1")
    Set ws2 = Worksheets("sheet2")
    Set ws3 = Worksheets("sheet3")

    ' mStopWatch.StartWatch

    values = Intersect(ws1.Columns(1), ws1.UsedRange)
    arr2 = Intersect(ws2.Range("A:B"), ws2.UsedRange)
    numcompared = UBound(arr2, 1)

    ' collect unique values and their frequencies
    For i = 1 To UBound(values, 1)
        uniq(values(i, 1)) = uniq(values(i, 1)) + 1
    Next i

    numresults = 0
    ' 2nd index is repeat count
    For j = 1 To numcompared
        arr2(j, 2) = 0
    Next j

    For Each v In uniq
        searchterm = "-" & v & "-"
        cnt = uniq.Item(v)
        For j = 1 To numcompared
            If InStr(1, arr2(j, 1), searchterm) > 0 Then
                ' copy this value multiple times into result array
                arr2(j, 2) = arr2(j, 2) + cnt ' repeat count
                numresults = numresults + cnt
            End If
        Next j
    Next

    ' generate output list
    ReDim results(1 To numresults, 1 To 2)
    ws3.Columns(1).Clear
    nextresult = 0
    For i = 1 To numcompared
        v = arr2(i, 1)
        cnt = arr2(i, 2)  ' may be 0!
        For j = 1 To cnt
            results(nextresult + j, 1) = v
        Next j
        nextresult = nextresult + cnt
    Next i

    ' copy values to sheet
    ws3.Range(Cells(1, 1), Cells(nextresult, 2)) = results

    ' Debug.Print "runtime = " & Format(mStopWatch.StopWatch, "#0.00 ms")
    Debug.Print Format(nextresult, "#,### resulting lines")
End Sub

与 OP 的代码相比，速度提高了 1:186。20 分钟的运行只需要几秒钟。

答案3

我会使用 Power Query 插件来实现这一点。它有一个 Text.Contains 函数，与 VB 的 InStr 大致相似。我尝试了这个特殊的挑战并成功了。您可以从我的 OneDrive 下载并使用我的演示文件：

http://1drv.ms/1AzPAZp

它是文件：Power Query 演示 - 在另一个字符串列表中搜索一个字符串列表.xlsx。

正如自述文件上所述，我不需要编写很多功能 - 它主要是通过单击 UI 来构建的。

我的设计是交叉连接搜索表和目标表（我认为相当于您的 Sheet1 和 Sheet2）以获取所有可能的组合，然后应用 Text.Contains 函数并对结果进行过滤。

一个关键的设计目标是速度 - 它对于当前的半随机测试数据运行大约需要 1 秒：19 个搜索字符串（当前为单个单词）78780 个目标字符串（当前为《战争与和平》中的台词）（因此大约有 150 万种组合）9268 个输出匹配。

规模不小，但远达不到您的要求。希望它能满足您的需求 - 我很想知道进展如何。

请注意，Target_Strings 查询可以替换为直接从数据库或网站查询数据的查询 - Power Query 不仅限于 Excel 作为数据源。

相关内容