XL 2010 Compléter colonnes selon fichier de référence

KIM · 22 Février 2017

Bonjour le forum, bonjour les ami(e)s,
Votre réactivité dans ce forum m'a rendu beaucoup de services. Je reviens ainsi vers vous pour solliciter votre aide. J'ai un fichier de référence (CatGrpRef.xls) pour les catégories (3) et groupes (4).
- Les 3 catégories sont liées
- Chaque groupe est positionné à "Oui" selon le contenu des 3 catégories.
- Les données des catégories Cat_1 et Cat_2 sont figées Col B et C
- CAT_1 est obligatoire et ne peut pas être vide
-CAT_2 n'est pas obligatoire (vide)
- CAT_3 n'est pas obligatoire, peut être conforme aux données de la col D pour positionner les groupes à Oui sinon saisie libre. "*" veut dire vide ou saisie libre différente de la liste proposée.
Je reçois régulièrement un fichier de quelques milliers de lignes du type CompléterSelonCritères.xls. Je souhaite compléter les colonnes L, M, N, O à "Oui" et R pour les commentaires selon les catégories col I, J et K par les données correspondantes du fichier de référence (CatGrpRef.xls).
Les anomalies à traiter : Si CAT_1 et/ou CAT_2 ne sont pas conformes au tableau de référence :
-Il faut noter dans Commentaires (Col R) : CAT_2 INCONNU (par exemple, ligne 17) et appliquer la règle pour les groupes comme si CAT-2 est vide.
- Si Cat_1 est erronnée, c-à-d n'existe pas dans le référentiel (Col B), mettre "X" pour tous les groupes et dans Commentaires (Col R) : CAT_1 INCONNU (par exemple, ligne 24)
Ci-joints CatGrpRef.xls et CompléterSelonCritères.xls
Je vous remercie par avance de votre aide.
Bien cordialement KIM

Bebere · 26 Février 2017

bonsoir
Kim demon côté le code est commencé
si tu as encore des explications à donner c'est le moment

KIM · 26 Février 2017

Bonsoir Bebere et le forum,
Merci d'avance pour ton aide. Je reprends les anomalies pour être plus clair. Les 2 catégories sont liées.
CAT1 est obligatoire et conforme à la liste de la 1è colonne, en majuscule
CAT2 n'est pas obligatoire, peut être vide ou conforme à la liste de la 2è col
CAT3 n'est pas obligatoire, elle est en saisie libre. "*" veut dire vide ou n'importe quoi ou bien elle doit être conforme aux données de la 3è col.
- Si CAT1 est vide mettre INCONNU en rouge dans la col CAT1 du fichier à traiter
- Si CAT1 est erronée, c-à-d n'est pas conforme à la liste de la 1è colonne, casse à respecter (1è colonne en majuscule) : Mettre la cellule de la CAT1 en rouge et Mettre dans la col commentaires : CAT 1 erronée ;
- Si CAT1 est OK, CAT2 erronée : CAT2 doit aussi être conforme à la liste de la 2è colonne ou vide. Traitement comme si CAT2 est vide , Mettre CAT2 en rouge et mettre dans Commentaire : CAT1 OK, CAT2 erronée
- Si CAT1 OK, CAT2 OK, CAT3 : CAT3 est soit vide ou n'importe quoi, soit conforme aux données existante de CAT3 dans le fichier de référence.

Si nécessaire d'apporter d'autres explications dis le moi.
Merci encore. KIM

Bebere · 28 Février 2017

bonjour Kim
voilà un début de code
si cat1="" ok
test casse ok
aaaa ?ex:ligne 17 en rouge par rapport aux autres
compare pour vide
compare1 pour aaaa
compare2 pour bcda
compare3 pour xyz
j'espère que d'après tes déductions ou celles de quelqu'un d'autre
ma lanterne s'éclairera

Code:

'Option Explicit
Option Compare Text
Dim a, ligne As Long

Sub essai()
    Dim d As New Dictionary, d1 As Dictionary
    Dim i As Long, l As Long, c As Byte, x As Byte
    Workbooks.Open ThisWorkbook.Path & "\" & "CatGrpRef.xls"
    tblCat = ActiveWorkbook.Worksheets("RefCatGrp").Range("B6:D21")
    TblGrp = ActiveWorkbook.Worksheets("RefCatGrp").Range("F6:K21")
    ActiveWorkbook.Close False
    a = Feuil2.Range("I11:R" & Feuil1.Range("I65536").End(xlUp).Row)
    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    ': Index = Index + 1
        For i = 2 To UBound(a, 1)
            If a(i, 1) = Item 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 Item
            Case "vide"
            x = Compare(a(ligne, 1))
                a(ligne, 1) = tblCat(x, 1)
                a(ligne, 4) = TblGrp(x, 1)
                a(ligne, 5) = TblGrp(x, 2)
                a(ligne, 6) = TblGrp(x, 3)
                a(ligne, 10) = "Cat1" & "-" & tblCat(x, 1) & 3
               
            Case "AAAA"
            x = Compare1(a(ligne, 1))
            If x > 0 Then
               a(ligne, 2) = tblCat(x, 2)
                a(ligne, 5) = TblGrp(x, 1)
                a(ligne, 6) = TblGrp(x, 2)
                a(ligne, 7) = TblGrp(x, 3)
                a(ligne, 8) = TblGrp(x, 4)
            End If
           
            Case "BCDA-BF"
            x = Compare2(a(ligne, 1))
           
             Case "XYZ-PRT"
            x = Compare3(a(ligne, 1))
          
            End Select
            'test Maj min
            If a(ligne, 1) <> "vide" Then
                If Asc(a(ligne, 1)) >= 95 Then a(ligne, 10) = "Cat1" & "-" & "erroné"    '95 a 3 rouge
            End If
            Clé = CléBase & indice
            indice = indice + 1
        Loop

    Next Item

End Sub

Function Compare(critere) 'vide testé
    Dim test As Boolean

    If critere = "vide" Then    'CAT1
        Compare = 16: Exit Function
    End If

        If test Then Compare = i Else Compare = 0

    End Function

Function Compare1(critere) 'aaaa testé
    Dim test As Boolean
   
    For i = 1 To 5
        If tblCat(i, 1) = critere Then
        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, 3) = tblCat(i, 2) And a(ligne, 3) = "" Then
                If tblCat(i, 3) = "*" Then test = True: Exit For
            End If
            End If

            If a(ligne, 2) = "" And a(ligne, 3) <> "" Then
                If a(ligne, 3) <> "" And tblCat(i, 3) <> "*" Then test = True: Exit For
            End If
End If
Next

       If i < 6 Then Compare1 = i

    End Function
   
Function Compare2(critere) 'bcda comparaison en exemple
    Dim test As Boolean
   
    For i = 6 To 11
        If tblCat(i, 1) = critere And a(ligne, 2) = "" And a(ligne, 3) = "" Then
            If tblCat(i, 2) = "" And tblCat(i, 3) = "*" Then test = True: Exit For
            End If
           
       If tblCat(i, 1) = critere And a(ligne, 2) = "" And a(ligne, 3) = "" Then
            If a(ligne, 3) = tblCat(i, 2) And a(ligne, 3) = "" Then
                If tblCat(i, 3) = "*" Then test = True: Exit For
            End If
            End If

            If tblCat(i, 1) = critere And 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 Compare = i Else Compare = 0

    End Function

   
Function Compare3(critere) 'xyz comparaison en exemple
    Dim test As Boolean
   
    For i = 12 To 15
        If tblCat(i, 1) = critere And a(ligne, 2) = "" And a(ligne, 3) = "" Then
            If tblCat(i, 2) = "" And tblCat(i, 3) = "*" Then test = True: Exit For
            End If
           
       If tblCat(i, 1) = critere And a(ligne, 2) = "" And a(ligne, 3) = "" Then
            If a(ligne, 3) = tblCat(i, 2) And a(ligne, 3) = "" Then
                If tblCat(i, 3) = "*" Then test = True: Exit For
            End If
            End If

            If tblCat(i, 1) = critere And 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 Compare = i Else Compare = 0

    End Function

KIM · 28 Février 2017

Bonsoir Bebere et le forum,
Merci pour ton code. Je le testerai dès mon retour au bureau vendredi .
A la 1è lecture du code, Cat1 ne doit pas être vide. Si vide, Cat1 doit être remplacé par INCONNU et mettre dans la col commentaire Cat1 erronée.
Dès que possible je testerai l'ensemble des fonctions et te fera un retour.
Merci encore.
KIM

Bebere · 1 Mars 2017

bonjour
Kim la cellule soit disant vide peut contenir un espace ou autre caractère,il y a vide pour être sûr
pour inconnu et la casse c'est bon.pour les autres?
pour le moment rien n'est mis dans la feuille
pour AAAA il y a 3 lignes les mêmes 13,17,19 pourquoi la 17 en rouge et ajout de ABAB et pas les 2 autres
pour les 2 autres cas rien n'est fait c'est recopie du code compare
quand les comparaisons seront au point il sera peut être possible de regrouper

KIM · 1 Mars 2017

Bonsoir Bebere et le forum,
J'ai voulu tester ton code, j'ai un message d'erreur pour les déclarations : Dim d As New Dictionary, d1 As Dictionary : "Erreur de compilation, Type défini par l'utilisateur non défini" .
Comment modifier la déclaration d et d1 ?
- Pour AAAA, 2 lignes seulement sont identiques , lignes 13 et 19
Pour la ligne 17 : Cat2 = ABAB n'existe pas dans le fichier de référence pour Cat1=AAAA. Il faut donc appliquer le traitement pour Cat1 = AAAA, Cat2 = vide et Cat3=*
Merci d'avance pour ton aide
KIM

Bebere · 2 Mars 2017

bonjour
Kim
dans menu outils choisir références et cocher la ligne microsoft scripting runtime
ou mettre

Code:

Set d = CreateObject("Scripting.Dictionary")

idem pour d1

KIM · 2 Mars 2017

Bonjour Bebere,
En effet j'ai déjà coché Microsoft Scripting runtime,
par contre j'ai d'autres message d'erreurs concernant la déclaration des tblCat, et TblGrp : Erreur Sub ou Function non définie au niveau de la fonction Compare1.
Si je mets Dim tblCat As Range : Erreur Variable objet ou variable de bloc with non définie
Si je mets Dim tblCat, Erreur : SUb ou Function non Définie pour tblCAT dans Compare1

Merci de m'éclairer,
KIM

Bebere · 2 Mars 2017

Kim
Dim Tblcat as variant ou simplement tblcat
ils sont déclarés en dehors de sub,en dessous des lignes commençant par option
excuses içi ils sont dans module1 en public
je suis rentré et demain je suis là,j'au du temps pour continuer

KIM · 2 Mars 2017

Bonsoir Bebere,
Merci pour tout le temps que tu consacres à ce forum, à mes discussions en particulier et celle en cours.
En, attendant bonne soirée.

KIM

Bebere · 4 Mars 2017

bonjour
Kim voilà où notre feuilleton en est
ajout d'un code pour effacer feuil2(partie pour essai) et d'un tableau pour les lignes à colorer
maintenant le résultat va dans la feuille
il y a encore des erreurs,entretemps je continue de tester

Code:

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
'*** 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"
                x = Compare(a(Ligne, 1))
                a(Ligne, 1) = tblCat(x, 1)
                a(Ligne, 4) = TblGrp(x, 1)
                a(Ligne, 5) = TblGrp(x, 2)
                a(Ligne, 6) = TblGrp(x, 3)
                If Couleur = 3 Then    '  'test couleur
                    a(Ligne, 10) = "Cat1" & " inconnu"
                    ReDim Preserve TblCouleur(iCouleur): TblCouleur(iCouleur) = Ligne: iCouleur = iCouleur + 1
                    Couleur = 0
                End If
            Case "AAA"    'A"
                x = Compare1(a(Ligne, 1))
                If x > 0 Then
                    a(Ligne, 2) = tblCat(x, 2)
                    a(Ligne, 10) = "Cat1" & "-" & tblCat(x, 2)    'commentaire
                    a(Ligne, 5) = TblGrp(x, 1)
                    a(Ligne, 6) = TblGrp(x, 2)
                    a(Ligne, 7) = TblGrp(x, 3)
                    a(Ligne, 8) = TblGrp(x, 4)
                    If Couleur = 3 Then    '  'test couleur
                        a(Ligne, 10) = "Cat1"
                        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
                    a(Ligne, 5) = TblGrp(x, 1)
                    a(Ligne, 6) = TblGrp(x, 2)
                    a(Ligne, 7) = TblGrp(x, 3)
                    a(Ligne, 8) = TblGrp(x, 4)
                    If Couleur = 3 Then    '  'test couleur
                        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
                    a(Ligne, 5) = TblGrp(x, 1)
                    a(Ligne, 6) = TblGrp(x, 2)
                    a(Ligne, 7) = TblGrp(x, 3)
                    a(Ligne, 8) = TblGrp(x, 4)
                    If Couleur = 3 Then    '  'test couleur
                        a(Ligne, 2) = tblCat(x, 2)
                        a(Ligne, 10) = "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" & "-" & "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
    Next i

End Sub

Function Compare(critere)    'vide testé
    Dim test As Boolean, i As Long

    If critere = "vide" Then    'CAT1
        Compare = 16: Couleur = 3: Exit Function
    End If

    If test Then Compare = i Else Compare = 0

End Function

Function Compare1(critere)    'aaaa testé
    Dim test As Boolean, i As Long
    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
            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    '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 VerifieCat3(CStr(a(Ligne, 3))) Then
            If tblCat(i, 2) <> "" And a(Ligne, 3) = tblCat(i, 3) Then Couleur = 3: test = True: Exit For
        End If
        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 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

KIM · 4 Mars 2017

Bonjour Bebere,
Je viens de regarder ton code, les données mises en colonnes I à R est le résultat souhaité selon le fichier de référence CatGrpRef.xls.
Le test
If Cel.Value = "INCONNU" Then Cel.Value = "" n'est pas correct car Cat1 = INCONNU est traité dans le fichier de référence CatGrpRef.xls.
Par contre une des anomalies à traiter c'est : Cat1 est obligatoire dans le fichier CompleterSelonCritères.xls, Col I, non vide et conforme à la liste Cat1 du fichier de référence.
1/ Si Cat1 est vide ou espace ou non conforme à la liste Cat1 du fichier CatGrpRef.xls, remplacer la cellule par INCONNU et traiter les colonnes L à R comme si Cat1 = INCONNU, et mettre le commentaire ci-dessous dans la col R.
Exemple dans la col I je retrouve " toto". "toto" n'est pas conforme à Cat1 du fichier de référence. Je remplace toto par INCONNU. Est-il possible de sauvegarder l'ancien contenu de la cellule "toto" dans une variable pour mettre dans la col R : Cat1 = toto INCONNU en rouge.
2/ S'il n'y a pas d'anomalies dans Cat1 et Cat2 et s'il y a des commentaires dans le fichier de référence, il est nécessaire de recopier le commentaire du fichier de référence dans la col R du fichier à traiter.
Je regarde les autres tests .
En attendant, Merci encore et Bonne soirée KIM

Bebere · 5 Mars 2017

bonjour
Kim voilà où j'en suis pour le moment
rmq😛our inconnu,au départ les cellules colonne cat1 de listacompleter sont vides
le code(inconnu) est changé et ajout code pour avoir les commentaires

Code:

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

KIM · 5 Mars 2017

Bonjour Bebere et le forum,
Je vais tester ton nouveau code.
J'étais en train de travailler sur les anomalies ci-joint un fichier avec des explications sur les anomalies rencontrées.
Merci encore,
A suivre
Bonne journée
KIM

XL 2010 Compléter colonnes selon fichier de référence

KIM

XLDnaute Accro

Pièces jointes

Bebere

XLDnaute Barbatruc

KIM

XLDnaute Accro

Bebere

XLDnaute Barbatruc

KIM

XLDnaute Accro

Bebere

XLDnaute Barbatruc

KIM

XLDnaute Accro

Bebere

XLDnaute Barbatruc

KIM

XLDnaute Accro

Bebere

XLDnaute Barbatruc

KIM

XLDnaute Accro

Bebere

XLDnaute Barbatruc

KIM

XLDnaute Accro

Bebere

XLDnaute Barbatruc

KIM

XLDnaute Accro

Pièces jointes

Discussions similaires

XL 2010 Compléter colonnes selon fichier de référence

XLDnaute Accro

Pièces jointes

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

XLDnaute Barbatruc

XLDnaute Accro

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency