XL 2019 Boucle sur plusieurs dico

Dim Dico As Object
Set Dico = CreateObject("Scripting.Dictionary")

Set Dico("CA1") = CreateObject("System.Collections.SortedList")
Set Dico("CA2") = CreateObject("System.Collections.SortedList")
Set Dico("CA3") = CreateObject("System.Collections.SortedList")
Set Dico("CA4") = CreateObject("System.Collections.SortedList")
Set Dico("CA5") = CreateObject("System.Collections.SortedList")

        For Each Cell In .Range("A2:A" & .Range("A65000").End(xlUp).Row)
        If Cell.Value = "" Then Exit For
        'regrouper tous les champs entre eux et en isolant les "CAx"
                For K = 1 To 3
                    CANum = Right(Left(.Cells(Cell.Row, .Range("APSA" & K).Column), 3), 1)
                    APSAS = Right(.Cells(Cell.Row, .Range("APSA" & K).Column), Len(.Cells(Cell.Row, .Range("APSA" & K).Column)) - 4)
                    Dico("CA" & CANum)(APSAS) = Dico("CA" & CANum)(APSAS) + 1
                Next K
        Next Cell

A = Dico.keys
With Sheets("résultats")
.UsedRange.Delete
    For CA = 0 To UBound(A) - 1
             For CB = 0 To Dico(A(CA)).Count - 1
             .Cells(.Cells.Rows.Count, "A").End(xlUp).Offset(1) = A(CA)
           .Cells(.Cells.Rows.Count, "A").End(xlUp).Offset(, 1) = Dico(A(CA)).getkey(CB)
            .Cells(.Cells.Rows.Count, "A").End(xlUp).Offset(, 2) = Dico(A(CA)).Item(Dico(A(CA)).getkey(CB))
       Next
    Next
End With

Private Sub CommandButton1_Click()
    Dim Dico(1 To 5) As Object
    Dim Cell As Range
    Dim DerLigF2 As Long
    Dim ws As Worksheet
    Dim K As Byte
    Dim CANum As Integer
    Dim APSAS As String
    Dim NbAPSA As Integer
   
    ' Initialiser les dictionnaires
    For K = 1 To 5
        Set Dico(K) = CreateObject("Scripting.Dictionary")
    Next K
   
    With Feuil1
        ' Parcourir les cellules et remplir les dictionnaires
        For Each Cell In .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
            If Cell.Value <> "" Then
                For K = 1 To 3
                    CANum = CInt(Right(Left(.Cells(Cell.Row, .Range("APSA" & K).Column), 3), 1))
                    APSAS = Mid(.Cells(Cell.Row, .Range("APSA" & K).Column), 5)
                    If CANum >= 1 And CANum <= 5 Then
                        If Not Dico(CANum).Exists(APSAS) Then
                            Dico(CANum).Add APSAS, APSAS
                        End If
                    End If
                Next K
            End If
        Next Cell
    End With
   
    ' Créer une nouvelle feuille pour les résultats
        On Error Resume Next
        Worksheets("Feuil2").Delete
        On Error GoTo 0
        Set ws = ThisWorkbook.Sheets.Add
        ws.Name = "Feuil2"
   
    ' Ecrire les résultats dans Feuil2
    For K = 1 To 5
        DerLigF2 = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
        Call WriteDicoToSheet(Dico(K), "CA" & K, ws, DerLigF2)
    Next K
End Sub

Private Sub WriteDicoToSheet(Dico As Object, CA As String, ws As Worksheet, ByRef DerLigF2 As Long)
    Dim D As Variant
    Dim NbAPSA As Integer
    Dim i As Integer
   
    For Each D In Dico.Items
        NbAPSA = 0
        If D <> "" Then
            For i = 1 To 3
                NbAPSA = NbAPSA + Application.WorksheetFunction.CountIf(Feuil1.Range("APSA" & i), "=" & CA & "-" & D)
            Next i
        End If
        ws.Cells(DerLigF2, 1).Value = CA
        ws.Cells(DerLigF2, 2).Value = D
        ws.Cells(DerLigF2, 3).Value = NbAPSA
        DerLigF2 = DerLigF2 + 1
    Next D
End Sub

Private Sub CommandButton2_Click()
   Dim C As Integer, TInt(), TDon(), LD As Long, LI As Long, TRésu(), SGrCA As SsGr, SGrDsgn As SsGr, _
      SGrS As SsGr, ÀProduire As Boolean, NbTrouvés As Long, LR As Long
   ReDim TInt(1 To 4 * Me.UsedRange.Rows.Count, 1 To 3)
   TDon = Feuil2.[A2:B2].Resize(Feuil2.Cells(2 ^ 20, "A").End(xlUp).Row - 1).Value
   For LD = 1 To UBound(TDon, 1)
      LI = LI + 1
      TInt(LI, 1) = TDon(LD, 1)
      TInt(LI, 2) = TDon(LD, 2)
      TInt(LI, 3) = "A"
      Next LD
   For C = 1 To 3
      TDon = Me.Cells(2, C).Resize(Me.Cells(2 ^ 20, C).End(xlUp).Row - 1).Value
      For LD = 1 To UBound(TDon, 1)
         LI = LI + 1
         TInt(LI, 1) = Left$(TDon(LD, 1), 3)
         TInt(LI, 2) = Mid$(TDon(LD, 1), 5)
         TInt(LI, 3) = "B"
         Next LD, C
   ReDim TRésu(1 To LI, 1 To 3)
   MGigogne.DernièreLigneÀIndexer = LI
   For Each SGrCA In Gigogne(TInt, 1, 2, 3)
      For Each SGrDsgn In SGrCA.Co
         ÀProduire = False: NbTrouvés = 0
         For Each SGrS In SGrDsgn.Co
            If SGrS.Id = "A" Then
               ÀProduire = True
            Else
               NbTrouvés = SGrS.Count
               End If
            Next SGrS
         If ÀProduire Then
            LR = LR + 1
            TRésu(LR, 1) = SGrCA.Id
            TRésu(LR, 2) = SGrDsgn.Id
            TRésu(LR, 3) = NbTrouvés
            End If
         Next SGrDsgn, SGrCA
   Feuil2.[E2:G2].Resize(2 ^ 20 - 1).ClearContents
   Feuil2.[E2:G2].Resize(LR).Value = TRésu
   End Sub