Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 Boucle sur plusieurs dico

carlos

XLDnaute Impliqué
Supporter XLD
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
 
Solution
Bonsoir,
j'ai bien vérifié et au vu du classeur que tu as fournis je ne vois pas d'erreur!
VB:
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)...

Dranreb

XLDnaute Barbatruc
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.
 

Pièces jointes

  • GigogneCarlos.xlsm
    416.7 KB · Affichages: 3

carlos

XLDnaute Impliqué
Supporter XLD
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
 

dysorthographie

XLDnaute Accro
VB:
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

XLDnaute Barbatruc
Bonsoir,

Une variante


VB:
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

XLDnaute Barbatruc
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.)
VB:
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
 

Pièces jointes

  • GigogneCarlos.xlsm
    416.7 KB · Affichages: 4

carlos

XLDnaute Impliqué
Supporter XLD
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.
CA2Circuit training
857​
CA2Step
3752​
CA3Renforcement musculaire
97​
CA4Autre APSA
71​
CA5Course en duree
2947​
CA5Musculation
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

XLDnaute Accro
Bonsoir,
j'ai bien vérifié et au vu du classeur que tu as fournis je ne vois pas d'erreur!
VB:
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

XLDnaute Impliqué
Supporter XLD
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
 

Discussions similaires

Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…