针对数百万次计算优化宏

Question

我正在匹配单独文件的 id，如果发生匹配，源上的行将检索到另一个文件。我为两个文件做了一个 FOR 语句来扫描每一行，源工作簿有超过 27000 行，另一个大约有 8000 行，如果我理解正确的话，那就是 216M+ 计算，直到循环结束。我已经实现了screenUpdating = False和xlCalculationManual.但是我在这里，我等了大约 30 分钟，没有代码完成的迹象（VBA 编辑器和 Excel 都"没有响应"）。

For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Range("A" & filaIndiceFuente).Value
    For filaIndiceDestino = 2 To filaDestinoUltima
        ' filaIndiceDestino = filaIndiceDestino + 1
        If planillaDestino.Range("A" & filaIndiceDestino).Value = criterioFuente Then
        'CELLS GET TO THE OTHER FILE HERE
        End If
    Next filaIndiceDestino
Next filaIndiceFuente

在测试文件中，我实现了代码，它几乎立即运行并取得了积极的结果。如果你能暗示我改进代码的其他方法，我将不胜感激。

Answer 1

通常，

当我有一个大型数据集来迭代匹配项时，我发现使用字典甚至比.Find()操作或遍历每一行。

我会尝试类似的东西

Dim dict As New Scripting.Dictionary
For filaIndiceFuente = 2 To filaFuenteUltima
    dict.Add CStr(planillaFuente.Range("A" & filaIndiceFuente).Value), filaIndiceFuente '<- this will act as a pointer to the row where your match data is
Next filaIndiceFuente
For filaIndiceDestino = 2 To filaDestinoUltima
    If dict.Exists(CStr(planillaDestino.Range("A" & filaIndiceDestino).Value)) Then
        'CELLS GET TO THE OTHER FILE HERE
    End If
Next filaIndiceDestino
Set dict = Nothing

Answer 2

我可能会更进一步，将数据加载到数组中，然后遍历数组。 由于读取数组数据时的偏移量，indice 将偏离 1。 loadscp 例程中有一些绒毛，我构建它是为了重用。 我怀疑你不需要状态栏。

Dim scpFuente   As scripting.dictionary
Dim arrFuente    As variant 
Dim arrDest       As variant 
Arrfuente = planillaFuente.range(“a2”).resize(filaFuenteUltima-1,1).value
ArrDest = planillaDestino.range(“a2”).resize(filaDestinaUltima-1,1).value
Set scpFuente = loadscp(arrfuente)

For filaIndiceDestino = lbound(arrDest,1) to ubound(arrDest,1) 
    ' filaIndiceDestino = filaIndiceDestino + 1
    If scpFuente.exists(arrdest(filaindicedestino,1)) Then
    'CELLS GET TO THE OTHER FILE HERE
    End If
Next filaIndiceDestino

负载 scp 函数：

Public Function Loadscp(ByVal varList As Variant, Optional ByVal intCol As Integer = 1, _
Optional ByVal intCols As Integer = 1, Optional ByVal strDelim As String = ".") As Scripting.Dictionary
Dim scpList             As Scripting.Dictionary
Dim arrVals             As Variant
Dim lngLastRow          As Long
Dim lngRow              As Long
Dim intABSCol           As Integer
Dim intColCurr          As Integer
Dim strVal              As String
Dim intRngCol           As Integer
Set Loadscp = New Scripting.Dictionary
Loadscp.CompareMode = vbTextCompare
intABSCol = Abs(intCol)
If IsArray(varList) Then
    arrVals = varList
ElseIf TypeName(varList) = "Range" Then
    intRngCol = varList.Column
    lngLastRow = LastRow(varList.Parent, intCol)
    If lngLastRow > varList.Row Then
        arrVals = varList.Offset(1, intABSCol - 1).Resize(lngLastRow - varList.Row, 1)
    End If
ElseIf TypeName(varList) = "Dictionary" Then
    Set scpList = varList
    ReDim arrVals(1 To scpList.Count, 1 To 1)
    For lngRow = 1 To scpList.Count
        arrVals(lngRow, 1) = scpList.Keys(lngRow - 1)
    Next lngRow
End If
If IsArray(arrVals) Then
    For lngRow = LBound(arrVals, 1) To UBound(arrVals, 1)
        strVal = arrVals(lngRow, intCol)
        For intColCurr = intCol + 1 To intCol + intCols - 1
            strVal = strVal & strDelim & arrVals(lngRow, intColCurr)
        Next intColCurr
        If Not Loadscp.Exists(strVal) Then
            Loadscp.Item(strVal) = lngRow
        End If
    Next lngRow
End If
End Function

Answer 3

首先，我会添加 Application.Statusbar 值来控制它运行的时间其次，如果在内部循环中找到值，我会添加一个退出，以防止循环中不必要的步骤，例如：

For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Range("A" & filaIndiceFuente).Value
    if filaIndiceFuente  mod 50 = 0 then 
      **Application.statusbar = filaIndiceFuente**  
    end if
    For filaIndiceDestino = 2 To filaDestinoUltima
        ' filaIndiceDestino = filaIndiceDestino + 1
        If planillaDestino.Range("A" & filaIndiceDestino).Value = criterioFuente Then
        'CELLS GET TO THE OTHER FILE HERE
        **exit for**
        End If
    Next filaIndiceDestino
Next filaIndiceFuente
Application.statusbar = ""

您可以在内部循环中拥有状态栏信息

For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Range("A" & filaIndiceFuente).Value
    For filaIndiceDestino = 2 To filaDestinoUltima
        ' filaIndiceDestino = filaIndiceDestino + 1
        if filaIndiceDestino mod 50 = 0 then 
            **Application.statusbar = filaIndiceFuente & " - " & filaIndiceDestino **  
        end if
        If planillaDestino.Range("A" & filaIndiceDestino).Value = criterioFuente Then
        'CELLS GET TO THE OTHER FILE HERE
        **exit for**
        End If
    Next filaIndiceDestino
Next filaIndiceFuente
Application.statusbar = ""

我看不出有什么方法可以更快地进行比较，但也许其他人有更好的主意。将此视为确定花费很长时间的原因的第一步。

Answer 4

首先按 A 列升序对 planillaDest 范围进行排序，然后：

Dim lookupRange As Range
Set lookupRange = planillaDestino.Range("A2:A" & filaDestinoUltima)
For filaIndiceFuente = 2 To filaFuenteUltima
    criterioFuente = planillaFuente.Cells(filaIndiceFuente, "A").Value
    Dim matchRow As Long
    matchRow = Application.WorksheetFunction.Match(criterioFuente, lookupRange, 1)
    If lookupRange.Cells(matchRow, 1).Value = criterioFuente Then
        'CELLS GET TO THE OTHER FILE HERE
        ' If row to move from planillaFuente to planillaDest, then:
        planillaDest.Cells(matchRow + 1, "P").Value = planillaFuente.Cells(filaIndiceFuente, "D").Value
    End If
Next filaIndiceFuente