Оптимизировать макрос для миллионов расчетов

Обычно, когда у меня есть большой набор данных, который я перебираю для совпадений, я обнаруживаю, что использование словаря быстрее даже, чем операция. 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

Сначала отсортируйте диапазон planillaDest по возрастанию по столбцу A, затем:

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

Во-первых, я бы добавил значение 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 = ""

Я не вижу способа сделать сравнение быстрее, но, возможно, у кого-то есть идея получше. Посмотрите на это как на первый шаг, чтобы определить причину длительного приема.

Вероятно, я бы сделал еще один шаг, загрузил данные в массивы, а затем перебрал их. Индекс будет отключен на 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

Функция loadscp:

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