Option Explicit
Sub VroumVroum()
Dim dicoSKU As Object, dicoTypeProd As Object, dicoRes As Object
Dim tablo, i&, i2&, j&, j2&, k, k2&, tSKU, tTypeProd
Dim ligne, colonne, xrg As Range, t0
With Sheets("data")
' effacement des couleurs de fond précédentes
Set xrg = Intersect(.UsedRange, .Range("b4").Resize(100000, 10000))
xrg.Interior.ColorIndex = xlColorIndexNone
Set xrg = Nothing
' pour les test : permet d'effacer les couleurs des cellules de data
' sans devoir faire le taitement
If Not (MsgBox("RAZ des couleurs des cellules de DATA faite. Continuer ?", _
vbQuestion + vbYesNo + vbDefaultButton2) = vbYes) Then Exit Sub
Application.ScreenUpdating = False
t0 = Timer
' Acquisition de dicoSKU (key = colonne A de DATA) (Item = ligne de Key)
Set dicoSKU = CreateObject("scripting.dictionary")
tablo = .Range(.Range("A4"), .Range("A" & Rows.Count).End(xlUp)).Value
i2 = UBound(tablo)
For i = 1 To i2
If Not dicoSKU.exists(tablo(i, 1)) Then dicoSKU(tablo(i, 1)) = i + 3
Next i
' Acquisition de dicoTypeProd
' (key = ligne 3 de l'article produit) (Item = colonne de article produit)
Set dicoTypeProd = CreateObject("scripting.dictionary")
tablo = .Range(.Range("b3"), .Cells(3, Columns.Count).End(xlToLeft)).Value
j2 = UBound(tablo, 2)
For j = 1 To j2
If Not dicoTypeProd.exists(tablo(1, j)) Then dicoTypeProd(tablo(1, j)) = j + 1
Next j
End With
With Sheets("error-report")
' Acquisition des tablraux tSKUet tTypeProd (de la source)
tSKU = .Range(.Range("b6"), .Range("b" & Rows.Count).End(xlUp)).Value
tTypeProd = .Range(.Range("b6"), .Range("b" & Rows.Count).End(xlUp)).Offset(, 5).Value
i2 = UBound(tSKU)
End With
' initialisation de dicoRes
' dicoRES est dictionnair:
' dont les cles sont les numéros de ligne dans data des SKU de la source
' pour une clef donnée, l'item est un dictionnaire
' ce dictionnaire comprend les numéros de colonnes qui seront à colorier
' donc:
' une clef de dicoRES donne un numero de ligne de la feuille DATA
' l'item associée à cette clef donne un dictionnaire dont les cles sont les
' numéro de colonnes à colorier.
Set dicoRes = CreateObject("scripting.dictionary")
' remplissage dicoRes
For i = 1 To i2
If tSKU(i, 1) <> "" And tTypeProd(i, 1) <> "" Then
' ni SHU de la source, ni TypeProd de la source ne sont vides
If dicoSKU.exists(tSKU(i, 1)) And dicoTypeProd.exists(tTypeProd(i, 1)) Then
' le SHU de la source et le TypeProd de la source sont présents sur DATA
If Not dicoRes.exists(dicoSKU(tSKU(i, 1))) Then
' C'est la première fois qu'on rencontre une ligne dans DAT pour un SKU
' On crée un élément dans dicoRES
Set dicoRes(dicoSKU(tSKU(i, 1))) = CreateObject("scripting.dictionary")
' on ajoute la clef dicoSKU(tSKU(i, 1)) (c'est la ligne de SKY dans data)
dicoRes(dicoSKU(tSKU(i, 1)))(dicoTypeProd(tTypeProd(i, 1))) = Empty
Else
' La ligne de SKU dans data existe déjà dans dicoRES,
' on rajoute le numéro de colonne de typeprod comme clef
dicoRes(dicoSKU(tSKU(i, 1)))(dicoTypeProd(tTypeProd(i, 1))) = Empty
End If
End If
End If
Next i
' Changement de couleur des cellules (ligne par ligne)
With Sheets("data")
For Each ligne In dicoRes.keys
For Each colonne In dicoRes(ligne).keys
If xrg Is Nothing Then Set xrg = .Cells(ligne, colonne) Else Set xrg = Union(xrg, .Cells(ligne, colonne))
Next colonne
Next ligne
xrg.Interior.Color = 16711935
End With
MsgBox "C'est fini ! (" & Format(Timer - t0, "#,##0.00") & " sec. )"
Application.Goto Sheets("data").Range("a1"), True
Application.ScreenUpdating = True
End Sub