Option Explicit
Option Compare Text
Dim a, Ligne As Long
Public tblCat, TblGrp, Couleur As Long, TblCouleur(), iCouleur As Long
Sub essai()
Dim d As Dictionary, d1 As Dictionary, Cel As Range
Dim i As Long, l As Long, c As Byte, x As Byte, Item As Variant
Dim Clé As String, CléBase As String, Indice As Long, Cat1 As String, Cat2 As String
'*** pour essai
Feuil2.Range("L11:R" & Feuil2.Range("I65536").End(xlUp).Row).ClearContents
Feuil2.Range("I11:I" & Feuil2.Range("I65536").End(xlUp).Row).Font.ColorIndex = xlAutomatic
Feuil2.Range("J17") = ""
For Each Cel In Feuil2.Range("I11:I" & Feuil2.Range("I65536").End(xlUp).Row)
If Cel.Value = "INCONNU" Then Cel.Value = ""
Next Cel
'***
a = Feuil2.Range("I11:R" & Feuil2.Range("I65536").End(xlUp).Row)
Workbooks.Open ThisWorkbook.Path & "\" & "CatGrpRef.xls"
tblCat = ActiveWorkbook.Worksheets("RefCatGrp").Range("B6:D21")
TblGrp = ActiveWorkbook.Worksheets("RefCatGrp").Range("F6:K21")
ActiveWorkbook.Close False
Set d = New Dictionary
For l = 1 To UBound(a, 1) 'cat1 sans doublon
If a(l, 1) = "" Then a(l, 1) = "vide"
d(a(l, 1)) = a(l, 1)
Next l
For Each Item In d.Items
Set d1 = New Dictionary 'a(I, 1) Like [Item]
For i = 1 To UBound(a, 1)
If Left(a(i, 1), 3) = Left(Item, 3) Then
CléBase = Item
Clé = CléBase
Indice = 1
Do While d1.Exists(Clé)
Clé = CléBase & Indice
Indice = Indice + 1
Loop
d1(Clé) = i
End If
Next i
CléBase = Item
Clé = CléBase
Indice = 1
Do While d1.Exists(Clé)
Ligne = d1(Clé)
Select Case Left(Item, 3)
Case "vid" 'e"
Cat1 = a(Ligne, 1)
a(Ligne, 1) = tblCat(16, 1) 'inconnu
a(Ligne, 4) = TblGrp(16, 1)
a(Ligne, 5) = TblGrp(16, 2)
a(Ligne, 6) = TblGrp(16, 3)
a(Ligne, 10) = "Cat1 " & Cat1
ReDim Preserve TblCouleur(iCouleur): TblCouleur(iCouleur) = Ligne: iCouleur = iCouleur + 1
Couleur = 0
Case "AAA" 'A"
x = Compare1(a(Ligne, 1))
If x > 0 Then
Cat1 = a(Ligne, 1)
Cat2 = IIf(a(Ligne, 2) = "", "vide", a(Ligne, 2))
a(Ligne, 2) = tblCat(x, 2)
a(Ligne, 4) = TblGrp(x, 1)
a(Ligne, 5) = TblGrp(x, 2)
a(Ligne, 6) = TblGrp(x, 3)
a(Ligne, 7) = TblGrp(x, 4)
If Couleur = 0 Then ' 'test couleur
If TblGrp(x, 6) <> "" Then a(Ligne, 10) = TblGrp(x, 6)
Else
If Cat2 = "" Then Cat2 = "vide"
a(Ligne, 10) = "Cat1 " & Cat1 & ",Cat2 " & Cat2
ReDim Preserve TblCouleur(iCouleur): TblCouleur(iCouleur) = Ligne: iCouleur = iCouleur + 1
Couleur = 0
End If
End If
Case "BCD" 'A-BF"
x = Compare2(a(Ligne, 1))
If x > 0 Then
Cat1 = a(Ligne, 1)
a(Ligne, 4) = TblGrp(x, 1)
a(Ligne, 5) = TblGrp(x, 2)
a(Ligne, 6) = TblGrp(x, 3)
a(Ligne, 7) = TblGrp(x, 4)
If Couleur = 0 Then ' 'test couleur
If TblGrp(x, 6) <> "" Then a(Ligne, 10) = TblGrp(x, 6)
Else
a(Ligne, 2) = tblCat(x, 2)
a(Ligne, 10) = "Cat1" & "-" & tblCat(x, 2) 'commentaire
ReDim Preserve TblCouleur(iCouleur): TblCouleur(iCouleur) = Ligne: iCouleur = iCouleur + 1
Couleur = 0
End If
End If
Case "XYZ" '-PRT"
x = Compare3(a(Ligne, 1))
If x > 0 Then
Cat1 = a(Ligne, 1)
Cat2 = a(Ligne, 2)
a(Ligne, 4) = TblGrp(x, 1)
a(Ligne, 5) = TblGrp(x, 2)
a(Ligne, 6) = TblGrp(x, 3)
a(Ligne, 7) = TblGrp(x, 4)
If Couleur = 0 Then ' 'test couleur
If TblGrp(x, 6) <> "" Then a(Ligne, 10) = TblGrp(x, 6)
Else
a(Ligne, 2) = tblCat(x, 2)
a(Ligne, 10) = "Cat1 " & Cat1 & " erroné" 'commentaire
ReDim Preserve TblCouleur(iCouleur): TblCouleur(iCouleur) = Ligne: iCouleur = iCouleur + 1
Couleur = 0
End If
End If
End Select
'test Maj min
If a(Ligne, 1) <> "vide" Then
If Asc(a(Ligne, 1)) >= 95 Then
a(Ligne, 10) = "Cat1:" & a(Ligne, 1) & " erroné" ' "CAT1 OK, CAT2 erronée"
ReDim Preserve TblCouleur(iCouleur): TblCouleur(iCouleur) = Ligne: iCouleur = iCouleur + 1
End If
End If
Clé = CléBase & Indice
Indice = Indice + 1
Loop
Next Item
Feuil2.Range("I11").Resize(UBound(a, 1), UBound(a, 2)) = a
For i = LBound(TblCouleur) To UBound(TblCouleur)
Feuil2.Range("I" & TblCouleur(i) + 10).Font.ColorIndex = 3
If Right(Feuil2.Range("R" & TblCouleur(i) + 10), 4) = "vide" Then Feuil2.Range("J" & TblCouleur(i) + 10).Font.ColorIndex = 3
Next i
End Sub
Function Compare1(critere) 'aaaa testé
Dim test As Boolean, i As Long
For i = 1 To 5
If tblCat(i, 3) = "AC AB" And a(Ligne, 3) = tblCat(i, 3) Or tblCat(i, 3) = "ACAC" And a(Ligne, 3) = tblCat(i, 3) Then
Compare1 = i: Exit Function
End If
Next i
For i = 1 To 5
If Verifie(CStr(a(Ligne, 1)), CStr(tblCat(i, 1))) Then Couleur = 3
If a(Ligne, 2) = "" And a(Ligne, 3) = "" Then 'ok
If tblCat(i, 2) = "" And tblCat(i, 3) = "*" Then test = True: Exit For
End If
If a(Ligne, 2) <> "" And a(Ligne, 3) = "" Then 'ok
If a(Ligne, 2) = tblCat(i, 2) And tblCat(i, 3) = "*" Then test = True: Exit For
End If
If a(Ligne, 2) = "" And a(Ligne, 3) <> "" Then 'ok rouge
If tblCat(i, 2) <> "" And a(Ligne, 3) = tblCat(i, 3) Then Couleur = 3: test = True: Exit For
End If
Next
If i < 6 Then Compare1 = i
End Function
Function Compare2(critere) 'bcda
Dim test As Boolean, i As Long
For i = 6 To 11
If Verifie(CStr(a(Ligne, 1)), CStr(tblCat(i, 1))) Then Couleur = 3
If a(Ligne, 2) <> "" And a(Ligne, 3) = "" Then
If a(Ligne, 2) = tblCat(i, 2) And tblCat(i, 3) = "*" Then test = True: Exit For
End If
If a(Ligne, 2) <> "" And a(Ligne, 3) <> "" Then
If a(Ligne, 2) = tblCat(i, 2) And a(Ligne, 3) = tblCat(i, 3) Then test = True: Exit For
End If
If a(Ligne, 2) = "" And a(Ligne, 3) = "" Then
If tblCat(i, 3) = "*" Then test = True: Exit For
End If
Next
If test Then Compare2 = i ' Else Compare = 0
End Function
Function Compare3(critere) 'xyz comparaison en exemple
Dim test As Boolean, i As Long
For i = 12 To 15
If tblCat(i, 3) = "Mno pqr hij" And a(Ligne, 3) = tblCat(i, 3) Then
Compare3 = i: Exit Function
End If
Next i
For i = 12 To 15
If Verifie(CStr(a(Ligne, 1)), CStr(tblCat(i, 1))) Then Couleur = 3
If a(Ligne, 2) = "" And a(Ligne, 3) <> "" Then
If tblCat(i, 2) = "" And tblCat(i, 3) = "*" Then test = True: Exit For
End If
If a(Ligne, 2) <> "" And a(Ligne, 3) <> "" Then
If a(Ligne, 2) = tblCat(i, 2) And a(Ligne, 3) = tblCat(i, 3) Then test = True: Exit For
End If
If a(Ligne, 2) <> "" And a(Ligne, 3) = "" Then
If a(Ligne, 3) = tblCat(i, 3) Then test = True: Exit For
End If
Next
If test Then Compare3 = i ' Else Compare = 0
End Function
Function Verifie(x As String, y As String) As Boolean
Dim i As Long, c As String
For i = 1 To Len(y)
c = Mid(y, i, 1)
If Not c Like Mid(x, i, 1) Then
Verifie = True
Exit For
End If
Next i
End Function
Function VerifieCat3(x As String) As Boolean
Dim i As Long
For i = 1 To UBound(tblCat, 1)
If tblCat(i, 3) = x Then
VerifieCat3 = True
Exit For
End If
Next i
End Function