优化双循环excelvba

我想优化代码中比较两个表的许多循环

实际上，执行时间非常长，因为这两个表有大约1500行要比较。因此，代码末尾的双循环只是执行1500*1500个操作。因此，250 000次行动实在太多了

希望你能帮助我，我没有发现做其他事情的诀窍

代码如下：

'********************This code compare if some values are in the first table and not in the second one and then in the second one and not in the first one with 2 loops********************


x = DL_COMPARATIF + 4

For t = 2 To DL_COMPARATIF

If Application.WorksheetFunction.CountIf(Sheets("AFFRETEMENTS EN COURS").Range("T:T"), Sheets("COMPARATIF").Range("C" & t)) = 0 Then

        x = x + 1

        For k = 1 To 17

            Sheets("COMPARATIF").Cells(x, k) = Sheets("COMPARATIF").Cells(t, k)

        Next k

        Sheets("COMPARATIF").Range("R" & x) = "L'OT ne figure pas dans Excel."

        Sheets("COMPARATIF").Range("A" & x & ":S" & x).Interior.Color = RGB(221, 235, 247)

        Erreur_mois = True

End If

Next t

For t = 3 To DL_AFFRETEMENT

    If Application.WorksheetFunction.CountIf(Sheets("COMPARATIF").Range("C:C"), Sheets("AFFRETEMENTS EN COURS").Range("T" & t)) = 0 Then

        If Sheets("AFFRETEMENTS EN COURS").Range("V" & t) = "Affrété & faxé" Then

            x = x + 1

            Sheets("COMPARATIF").Range("A" & x) = Sheets("AFFRETEMENTS EN COURS").Range("B" & t) 'client
            Sheets("COMPARATIF").Range("C" & x) = Sheets("AFFRETEMENTS EN COURS").Range("T" & t) 'Numéro d'OT
            Sheets("COMPARATIF").Range("E" & x) = Sheets("AFFRETEMENTS EN COURS").Range("S" & t) 'Référence client
            Sheets("COMPARATIF").Range("F" & x) = Sheets("AFFRETEMENTS EN COURS").Range("I" & t) 'Date de chargement
            Sheets("COMPARATIF").Range("G" & x) = Sheets("AFFRETEMENTS EN COURS").Range("D" & t) 'Ville de chargement
            Sheets("COMPARATIF").Range("K" & x) = Sheets("AFFRETEMENTS EN COURS").Range("F" & t) 'Ville d'arrivée
            Sheets("COMPARATIF").Range("M" & x) = Sheets("AFFRETEMENTS EN COURS").Range("J" & t) 'Date de livraison
            Sheets("COMPARATIF").Range("N" & x) = Sheets("AFFRETEMENTS EN COURS").Range("K" & t) 'Prix client
            Sheets("COMPARATIF").Range("O" & x) = Sheets("AFFRETEMENTS EN COURS").Range("L" & t) 'Prix affrété
            Sheets("COMPARATIF").Range("P" & x) = Sheets("AFFRETEMENTS EN COURS").Range("M" & t) 'Marge
            Sheets("COMPARATIF").Range("Q" & x) = Sheets("AFFRETEMENTS EN COURS").Range("P" & t) 'Affrété
            Sheets("COMPARATIF").Range("R" & x) = "L'OT ne figure pas dans AKANEA"
            Sheets("COMPARATIF").Range("A" & x & ":Z" & x).Interior.Color = RGB(255, 192, 0)

            Erreur_mois = True


        End If

    End If

Next t


'**********************If rows columns T and C are the same, then we will compare 2 other columns********************************************


For n = 3 To DL_AFFRETEMENT

For t = 2 To DL_COMPARATIF

' Si les OT sont les mêmes

If CStr(Sheets("AFFRETEMENTS EN COURS").Range("T" & n).Value) = CStr(Sheets("COMPARATIF").Range("C" & t).Value) Then

' Alors on verifie que les prix correspondent et si pas correspondance on relève les colonnes + message et calcul de différence

    If CStr(Sheets("AFFRETEMENTS EN COURS").Range("K" & n).Value) <> CStr(Sheets("COMPARATIF").Range("N" & t).Value) Then

        x = x + 1

        For k = 1 To 17

            Sheets("COMPARATIF").Cells(x, k) = Sheets("COMPARATIF").Cells(t, k)

        Next

        Sheets("COMPARATIF").Range("R" & x) = "Ecart de prix client"

        Sheets("COMPARATIF").Range("S" & x) = Sheets("AFFRETEMENTS EN COURS").Range("K" & n) - Sheets("COMPARATIF").Range("N" & t)

        Sheets("COMPARATIF").Range("A" & x & ":S" & x).Interior.Color = RGB(169, 208, 142)

        Erreur_mois = True

    End If

    If CStr(Sheets("AFFRETEMENTS EN COURS").Range("L" & n).Value) <> CStr(Sheets("COMPARATIF").Range("O" & t).Value) Then

        x = x + 1

        For k = 1 To 17

            Sheets("COMPARATIF").Cells(x, k) = Sheets("COMPARATIF").Cells(t, k)

        Next

        Sheets("COMPARATIF").Range("R" & x) = "Ecart de prix affrété"

        Sheets("COMPARATIF").Range("S" & x) = Sheets("AFFRETEMENTS EN COURS").Range("L" & n) - Sheets("COMPARATIF").Range("O" & t)

        Sheets("COMPARATIF").Range("A" & x & ":S" & x).Interior.Color = RGB(47, 117, 181)

        Erreur_mois = True

    End If

End If

Next t

Next n

---

提前感谢您的宝贵帮助。

不要耍花招，只要你的魔法就行了

---

和代码的效率无关，但我会声明一些工作表变量，这些变量在这里对可读性有很大作用。我会这样做。谢谢。这看起来像是……的工作。。。注意：CR希望看到整个过程，而不仅仅是一个片段，创建范围数组，处理它们，然后将它们转储回工作表中。到目前为止，它将对代码的性能产生最大的影响。无论你在哪里做，计算机都在执行查找操作，速度很慢。执行一次并将结果存储在工作表变量中。同样，使用诸如RangeA&x&:S&x之类的字符串数学进行字符串数学运算比直接访问RangeA2.Cellsx，1.Resize1,19要慢。更好的是，将每个表中的第一个单元格（如RangeA2）存储到范围变量中，而不是每次都进行单元格查找。最后，如果使用.Cells、.Offset和.Resize会更干净、更易于维护，因为其目的是显而易见的。我想指出，执行wsCMP.RangeA&x比执行wsCMP.RangeA1.Cellsx慢，1。当您在整个代码（如op）中这样做时，肯定会产生影响。与RangeD2相比，使用字符串数学（如RangeD&5+i&:G&32+j）维护代码是一场噩梦。例如，Resize100,4。非常完美。我将学习更多关于词汇的知识。非常感谢你！

Option Explicit  
Sub process()

    ' matching cols
    Const col_CMP = "C"
    Const col_AFF = "T" ' Num?ro d'OT

    Dim wb As Workbook, wsAFF As Worksheet, wsCMP As Worksheet, count As Long
    Dim dictAFF As Object, dictCMP As Object
    Dim DL_COMPARATIF As Long, DL_AFFRETEMENT As Long, iRowCMP As Long, iRowAFF As Long
    Dim sKey As String, x As Long, Erreur_mois As Boolean
    Dim t0 As Single
    t0 = Timer

    ' configure
    Set wb = ThisWorkbook
    Set wsAFF = wb.Sheets("AFFRETEMENTS EN COURS") ' Current charters
    Set wsCMP = wb.Sheets("COMPARATIF") ' Comparative

    ' last rows
    DL_COMPARATIF = wsCMP.Range(col_CMP & Rows.count).End(xlUp).Row
    DL_AFFRETEMENT = wsAFF.Range(col_AFF & Rows.count).End(xlUp).Row

    ' build a lookup to CMP
    Set dictCMP = BuildLookup(wsCMP, col_CMP, 2, DL_COMPARATIF)

    ' build a lookup to AFF
    Set dictAFF = BuildLookup(wsAFF, col_AFF, 3, DL_AFFRETEMENT)

    ' scan COMPARATIF for no match with AFFRETEMENT
    count = 0
    Erreur_mois = False
    x = DL_COMPARATIF + 4
    For iRowCMP = 2 To DL_COMPARATIF
         sKey = wsCMP.Range(col_CMP & iRowCMP).Value
         sKey = Trim(sKey)

         If Not dictAFF.exists(sKey) Then
            count = count + 1
            x = x + 1
            wsCMP.Range("A" & x).Resize(1, 17) = wsCMP.Range("A" & iRowCMP).Resize(1, 17).Value
            wsCMP.Range("R" & x) = "L'OT ne figure pas dans Excel." ' does not appear in excel
            wsCMP.Range("A" & x & ":S" & x).Interior.Color = RGB(221, 235, 247) ' pale blue
            Erreur_mois = True
            ' no match remove
            If dictCMP.exists(sKey) Then dictCMP.Remove sKey
         End If
    Next

    MsgBox "Scanned " & wsCMP.Name & " Col " & col_CMP & " to row " & DL_COMPARATIF _
           & vbCr & "Match = " & dictCMP.count _
           & vbCr & "No Match = " & count, vbInformation, "Compare " & wsCMP.Name & " to " & wsAFF.Name

    ' scan AFFRETEMENT for no match with COMPARATIF
    count = 0
    For iRowAFF = 3 To DL_AFFRETEMENT
        sKey = wsAFF.Range(col_AFF & iRowAFF).Value
        sKey = Trim(sKey)

        If Not dictCMP.exists(sKey) Then
            count = count + 1

            If wsAFF.Range("V" & iRowAFF) = "Affrété & faxé" Then ' chartered and faxed
                x = x + 1
                With wsCMP
                    .Range("A" & x) = wsAFF.Range("B" & iRowAFF) 'client
                    .Range("C" & x) = wsAFF.Range("T" & iRowAFF) 'Num?ro d'OT
                    .Range("E" & x) = wsAFF.Range("S" & iRowAFF) 'R?f?rence client
                    .Range("F" & x) = wsAFF.Range("I" & iRowAFF) 'Date de chargement
                    .Range("G" & x) = wsAFF.Range("D" & iRowAFF) 'Ville de chargement
                    .Range("K" & x) = wsAFF.Range("F" & iRowAFF) 'Ville d'arriv?e
                    .Range("M" & x) = wsAFF.Range("J" & iRowAFF) 'Date de livraison
                    .Range("N" & x) = wsAFF.Range("K" & iRowAFF) 'Prix client
                    .Range("O" & x) = wsAFF.Range("L" & iRowAFF) 'Prix affr?t?
                    .Range("P" & x) = wsAFF.Range("M" & iRowAFF) 'Marge
                    .Range("Q" & x) = wsAFF.Range("P" & iRowAFF) 'Affr?t?
                    .Range("R" & x) = "L'OT ne figure pas dans AKANEA"
                    .Range("A" & x & ":Z" & x).Interior.Color = RGB(255, 192, 0) ' yellow
                End With
                Erreur_mois = True
            End If

            ' no match remove
            If dictAFF.exists(sKey) Then dictAFF.Remove sKey
         End If
    Next

    MsgBox "Scanned " & wsAFF.Name & " Col " & col_AFF & " to row " & DL_AFFRETEMENT _
           & vbCr & "Match = " & dictAFF.count _
           & vbCr & "No Match = " & count, vbInformation, "Compare " & wsAFF.Name & " to " & wsCMP.Name

    MsgBox "Items matched dictAFF=" & dictAFF.count & " dictCMP=" & dictCMP.count, vbInformation, "Matched"

    ' compare prices for matching records
    Dim diffA As Single, diffC As Single, OT As Variant
    count = 1
    For Each OT In dictAFF.keys

        ' Alors on verifie que les prix correspondent et si pas
        ' correspondance on rel?ve les colonnes + message et calcul de diff?rence
        ' So we check that the prices match and if not match
        ' we pick up the columns + message and difference calculation
        iRowAFF = dictAFF.Item(OT)
        iRowCMP = dictCMP.Item(OT)
        'Debug.Print "Match " & OT & " AFF Row=" & iRowAFF & " CMP=" & iRowCMP

        ' calc Customer price difference
        diffC = wsAFF.Range("K" & iRowAFF).Value - wsCMP.Range("N" & iRowCMP).Value
        If Abs(diffC) > 0 Then
            x = x + 1
            wsCMP.Range("A" & x).Resize(1, 17) = wsCMP.Range("A" & iRowAFF).Resize(1, 17).Value
            wsCMP.Range("R" & x) = "Ecart de prix client" ' Customer price difference
            wsCMP.Range("S" & x) = Round(diffC, 3)
            wsCMP.Range("A" & x & ":S" & x).Interior.Color = RGB(169, 208, 142) ' green
            Erreur_mois = True
        End If

        ' calc Charter price difference
        diffA = wsAFF.Range("L" & iRowAFF).Value - wsCMP.Range("O" & iRowCMP).Value
        If Abs(diffA) > 0 Then
            x = x + 1
            wsCMP.Range("A" & x).Resize(1, 17) = wsCMP.Range("A" & iRowAFF).Resize(1, 17).Value
            wsCMP.Range("R" & x) = "Ecart de prix affr?t?" ' Charter price difference
            wsCMP.Range("S" & x) = Round(diffA, 3)
            wsCMP.Range("A" & x & ":S" & x).Interior.Color = RGB(47, 117, 181) 'blue
            Erreur_mois = True ' error month
        End If

    Next
    MsgBox "Completed in " & Int(Timer = t0) & " seconds", vbInformation, "Complete"

End Sub

Function BuildLookup(ByRef ws As Worksheet, col As String, firstrow As Long, lastrow As Long) As Object

    Dim dict As Object, i As Long, sKey As String, t0 As Single
    t0 = Timer
    Set dict = CreateObject("Scripting.Dictionary")
    For i = firstrow To lastrow
         sKey = ws.Range(col & i).Value
         sKey = Trim(sKey)
         If Len(sKey) > 0 Then
            If dict.exists(sKey) Then
                MsgBox "Duplicate key '" & sKey & "' at row " & i, vbExclamation, "ERROR in col " & col & " " & ws.Name
            Else
                dict.Add sKey, i
            End If
        End If
    Next
    Set BuildLookup = dict

    MsgBox "Scanned Column " & col & " Rows " & firstrow & " to " & lastrow, _
           vbInformation, ws.Name & " Dictionary built in " & Int(Timer - t0) & " seconds"

End Function