Нет хитрости, только волхвы c из объектов словаря .
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