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

Option Explicit
Option Compare Text
Public a, b

Sub ErreurCat1()    'donne le nombre et les lignes
    Dim d1 As Dictionary, d As Dictionary, aa, bb, i As Long, Li As Long
    Dim c As Byte, L As Long, tblA(), z As Long, item, autre
    Dim clé, clébase, indice, ligne, tmp    ' As Variant
    Dim m1 As String, m2 As String, mm1, mm2, pos, crit
    Feuil3.Cells.Clear
    a = Feuil2.Range("I11:I" & Feuil2.Range("I65536").End(xlUp).Row)
    b = Feuil2.Range("I11:I" & Feuil2.Range("I65536").End(xlUp).Row) 'tableau corrigé pour cat1

    aa = Array("", " ", "AA*", "XYZ*", "BCD*", "autre")
    bb = Array("vide", "espace ", "Faute AAAA", "Faute XYZ-PRT", "Faute BCDA-BF", "Faute autre")
    c = 1
    For i = LBound(aa) To UBound(aa)
        Select Case i
        Case 0
            crit = aa(i)

        Case 1
            crit = aa(i)

        Case 2    'AAAA
            crit = aa(i)

        Case 3    'XYZ-PRT
            crit = aa(i)

        Case 4
            crit = aa(i)
        Case 5    'autre
            z = 0
            For L = 1 To UBound(a, 1)
                If Len(a(L, 1)) > 1 Then
                    If UCase(a(L, 1)) Like "AAA*" Or UCase(a(L, 1)) Like "XYZ*" Or UCase(a(L, 1)) Like "BCD*" Then
                    Else 'si plusieurs autres,écrire direct dans la feuille
'                        ReDim Preserve autre(z): autre(z) = a(L, 1) & "-" & i + 10: z = z + 1
                        autre = a(L, 1) & "-" & i + 10
                        crit = a(L, 1)
                    End If
               
                End If
            Next
        End Select
        Set d1 = New Dictionary
        For L = 1 To UBound(a, 1)
            If a(L, 1) Like crit Then
                clébase = crit
                clé = clébase
                indice = 1
                Do While d1.Exists(clé)
                    clé = clébase & indice
                    indice = indice + 1
                Loop
                d1(clé) = L
            End If

        Next L
        clébase = crit
        clé = clébase
        indice = 1
        Do While d1.Exists(clé)
            ligne = d1(clé)
            Select Case i
            Case 0    'vide
                ReDim Preserve tblA(0 To 1, 0 To z)
                tblA(0, z) = "I" & ligne + 10
                tblA(1, z) = bb(i)
                b(ligne, 1) = "INCONNU"
                z = z + 1

            Case 1    'espace
                ReDim Preserve tblA(0 To 1, 0 To z)
                tblA(0, z) = "I" & ligne + 10
                tblA(1, z) = bb(i)
                b(ligne, 1) = "INCONNU"
                z = z + 1

            Case 2    'AAAA
                If MajMin("AAAA", CStr(a(ligne, 1))) = False Then
                    ReDim Preserve tblA(0 To 1, 0 To z)
                    tblA(0, z) = "I" & ligne + 10
                    tblA(1, z) = bb(i)
                    b(ligne, 1) = "AAAA"
                    z = z + 1
                End If

            Case 3    'XYZ-PRT
                If MajMin("XYZ-PRT", CStr(a(ligne, 1))) = False Then
                    ReDim Preserve tblA(0 To 1, 0 To z)
                    tblA(0, z) = "I" & ligne + 10
                    tblA(1, z) = bb(i)
                    b(ligne, 1) = "XYZ-PRT"
                    z = z + 1
                End If

            Case 4    'BCDA-BF
                If MajMin("BCDA-BF", CStr(a(ligne, 1))) = False Then
                    ReDim Preserve tblA(0 To 1, 0 To z)
                    tblA(0, z) = "I" & ligne + 10
                    tblA(1, z) = bb(i)
                    b(ligne, 1) = "BCDA-BF"
                    z = z + 1
                End If
               
            Case 5 ' autre
                If autre <> "" Then 'If HasBounds(autre) Then
'                For Li = 0 To UBound(autre)
                ReDim Preserve tblA(0 To 1, 0 To z)
                tblA(0, z) = "I" & Mid(autre, InStr(autre, "-") + 1)
                tblA(1, z) = Mid(autre, 1, InStr(autre, "-") - 1)
                z = z + 1
'                Next Li
End If

            End Select

            clé = clébase & indice
            indice = indice + 1
        Loop
        If HasBounds(tblA) Then
            If [B1] = "" Then Li = 1 Else Li = [B2000].End(xlUp).Row + 1
            Feuil3.Cells(Li, 1) = UBound(tblA, 2) + 1    'nbre
            Feuil3.Cells(Li, 2) = tblA(1, 0)
            Li = Li + 1
            For L = 0 To UBound(tblA, 2)
                Feuil3.Cells(Li + L, 2) = tblA(0, L)
            Next
            Erase tblA
            z = 0: autre = ""
        End If
    Next i

End Sub

Function MajMin(x As String, y As String) As Boolean    'x=ref,y à tester
    Dim i As Long, a, b, c As Byte

    For i = 1 To Len(y)
        a = Mid(x, i, 1)
        b = Mid(y, i, 1)
        If Asc(a) = Asc(b) Then
            c = c + 1
        End If
    Next i
    If c = Len(x) Then MajMin = True ' Else MajMin = False

End Function


Public Function HasBounds(myArray As Variant)
Dim lb, ub
    lb = Empty: ub = Empty
    On Error Resume Next
    lb = LBound(myArray, 1)
    ub = UBound(myArray, 1)
    On Error GoTo 0
    HasBounds = Not (IsEmpty(lb) Or IsEmpty(ub))
End Function    'Tom Ogilvy