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