XL 2019 Boucle sur plusieurs dico

[carlos]

Bonjour,,
j'ai plusieurs Dico dont je récupère les items sans doublon et j'aimerais récupérer les valeurs sur chacul des Dico à partir d'une boucle K.
Du genre :
For K = 1 to 5
For Each D In Dico & " K".Items

Mais je ne sais pas si c'est possible.
Bonne journée

 

[Dranreb]

Les 3 colonnes sont à mélanger, ou bien on en retrouve une trace dans le résultat ?
En tout cas j'ai équipé votre classeur des modules de service.

 

[carlos]

MerciDysorthographe,
Cette premièr partie semble bien fonctionner. Je vous remercie.
Apres des que je passe sur la lecture du Dico avec :
For KK = 1 To 5
For Each D In Dico(KK).Items... Ca plante :"Objet Requis"
Si je mets :
For KK = 1 To 5
For Each D In Dico("1").Items ..... Ca marche mais je n'ai plus de boucle possible

 

[carlos]

Je n'avais pas vu le retour de DanReb. Je regarde

 

[dysorthographie]

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

 

[laurent950]

Bonsoir,

Une variante

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

 

[Dranreb]

Une version qui ne reproduit que les éléments figurant déjà dans le Résultat à produire, mais les incluant tous, même s'ils ne figurent pas dans la feuille de départ.
(Destiné à remplacer le contenu des colonnes A:C, mais versé en attendant pour vérification en E:G.)

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

 

[carlos]

Bonjour,
Je suis impressionné par le travail de chacun et les chemins différents pour y arriver.
J'ai regardé les résultats de Dranreb, Laurent950, Dysorthographie.

Dysorthographie s'intègre très bien dans mon code mais il semble manquer les elements suivants par rapport à Laurent950 qui semble avoir pris en compte tous les elements de la BDD. Je ne suis pas capable de comprendre pourquoi.

CA2	Circuit training	857​
CA2	Step	3752​
CA3	Renforcement musculaire	97​
CA4	Autre APSA	71​
CA5	Course en duree	2947​
CA5	Musculation	8786​

Dranreb avec sa formule Gigogne à tous les elements. Il est parti de mes résultats pour me proposer une comparaison. Ce qui est très interessant. mais je me suis aperçu que mon code à la base produisait quelques résultats erronées par exemple CA3-Course d'orientation qui n'existe pas dans la base de départ comme le precisait Dranreb : "Une version qui ne reproduit que les éléments figurant déjà dans le Résultat à produire, mais les incluant tous, même s'ils ne figurent pas dans la feuille de départ.") .
C'est vraiment du très très bon travail et je vais pouvoir avancer et apprendre de nouvelles manières de construire du code.
Bonne journée

 

[dysorthographie]

Bonsoir,
j'ai bien vérifié et au vu du classeur que tu as fournis je ne vois pas d'erreur!

Private Sub CommandButton1_Click()
Dim Cell As Range, CANum As String, K(), CA As Integer, CB As Integer

Dim Dico As Object
Set Dico = CreateObject("Scripting.Dictionary")
For CA = 1 To 5
    Set Dico("CA" & CA) = CreateObject("System.Collections.SortedList")
Next

For Each Cell In Sheets("BDD").Range("A1").CurrentRegion
    If Cell.Value <> "" And Cell.Row > 1 Then
        CANum = Trim(Split(Cell & "-", "-")(0))
        APSAS = Trim(Split(Cell & "-", "-")(1))
        If Dico.exists(CANum) Then Dico(CANum)(APSAS) = Dico(CANum)(APSAS) + 1
    End If
Next

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

 

[carlos]

Bonsoir,
j'ai bien vérifié et au vu du classeur que tu as fournis je ne vois pas d'erreur!

Private Sub CommandButton1_Click()
Dim Cell As Range, CANum As String, K(), CA As Integer, CB As Integer

Dim Dico As Object
Set Dico = CreateObject("Scripting.Dictionary")
For CA = 1 To 5
    Set Dico("CA" & CA) = CreateObject("System.Collections.SortedList")
Next

For Each Cell In Sheets("BDD").Range("A1").CurrentRegion
    If Cell.Value <> "" And Cell.Row > 1 Then
        CANum = Trim(Split(Cell & "-", "-")(0))
        APSAS = Trim(Split(Cell & "-", "-")(1))
        If Dico.exists(CANum) Then Dico(CANum)(APSAS) = Dico(CANum)(APSAS) + 1
    End If
Next

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

Bonjour Dysorthographie,
Merci beaucoup pour la qualité de tes échanges et ton travail.
Je vais restester ton code bien écrit et a raccourci considérablement ma macro.
Bonne journée

 

[carlos]

Bonjour Dysorthographie,
Merci beaucoup pour la qualité de tes échanges et ton travail.
Je vais restester ton code bien écrit et a raccourci considérablement ma macro.
Bonne journée

J'ai restesté avec le nouveau code ett cela marche très bien. Touls les elements y sont.
Merci beaucoup.