XL 2010 Boucle imbriquée VBA

[sams96]

Bonjour à tous ,
je viens vers vous car je bloque pour faire une boucle ,
je cherche à faire une boucle qui va d'abord parcourir toute la colonne A ( Catégorie) , puis à chaque fois ou cette boucle trouve un texte en gras , elle devra parcourir toute ses sous catégories et afficher dans la colonne H , l ,J, k la sous catégorie ayant la valeur la plus élevée de la colonne E , j ai mis un exemple du résultat que je recherche sur le fichier excel ,
Sans pour autant oublié que mon tableau est dynamique , c'est dire que si on a une catégorie qui s'ajoute , cela va impliqué de nouvelles sous catégorise , donc le résultat final aura des lignes en plus .
prière de bien vouloir m'aider , je commence vraiment à perdre espoir .

 

[Ikito]

Bonjour sams96,

Certainement pas le mieux optimisé, mais fonctionnel.
Tu trouveras ton classeur en PJ.

Sub Boucle()
    
    Ligne = 2
    
    NbTour = Cells(1, "N").Value
    
    For i = 1 To NbTour
        If (Cells(i, 2) <> "") Then
            CN1 = Cells(i, 5).Value
            CN2 = Cells(i + 1, 5).Value
            If (CN2 <> "") Then
                If (CN1 > CN2) Then
                    sauvegarde = CN1
                    SaveLigne = i
                Else
                    sauvegarde = CN2
                    SaveLigne = i + 1
                End If
            End If
        Else
        If (SaveLigne <> "") Then
            Range("B" & SaveLigne & ":E" & SaveLigne).Copy _
            Destination:=Range("H" & Ligne)
            Ligne = Ligne + 1
            End If
        End If
    Next
End Sub

 

[Robert]

Bonjour Sams, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim TL() As Variant 'déclare la variable TL (Tableau des lignes)
Dim R As String 'déclare la variable R (Référence)
Dim I As Integer 'déclare la variable I (Incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim C As Byte 'déclare la variable C (Couleur)

Range("H2").CurrentRegion.ClearContents 'efface d'éventuelle anciennes valeurs à partir de H2
TV = Range("A1").CurrentRegion 'définit le tableau des valeurs TV
K = 1 'initialise la variable K
ReDim Preserve TL(1 To 2, 1 To K) 'redimensionne le tableau des lignes (2 lignes , K colonnes)
TL(1, K) = 2: R = TV(1, 1) 'récupère dans la ligne 1 de TL la ligne de début de plage K, définit la référence R
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    If TV(I, 1) <> R And Not TV(I, 1) = "" Then 'condition : si la donnée en ligne I colonne 1 de TV est différente de R et non vide
        TL(2, K) = I - 1 'récupère dans la ligne 2 de TL la ligne de fin de plage K
        K = K + 1 'incrément K
        ReDim Preserve TL(1 To 2, 1 To K) 'redimensionne le tableau des lignes
        TL(1, K) = I + 1 'recupère dans la ligne 1 de TL la ligne de début de la plage K
        R = TV(I, 1) 'redéfinit la référence R
    End If 'fin de la condition
Next I 'prochaine ligne de la boucle
TL(2, K) = Cells(Application.Rows.Count, "B").End(xlUp).Row 'définit la ligne de fin de la dernière plage
'le tableau TL contient la ligne de début et la ligne de fin de chaque plage ayant la même référence

For I = 1 To K 'boucle 1 : sur toutes les plages différentes
    M = Application.WorksheetFunction.Max(Range(Cells(TL(1, I), 5), Cells(TL(2, I), 5))) 'définit la valeur max de la plage
    For J = TL(1, I) To TL(2, I) 'boucle 2 : sur toutes les lignes de la plage
        If TV(J, 5) = M Then 'condition : si la donnée ligne J colonne 5 de TV est égale à la valeur max M
            PLV = Cells(Application.Rows.Count, "H").End(xlUp).Row + 1 'définit la première luigne vide PLV de la colonne H
            Cells(J, 2).Resize(, 4).Copy Cells(PLV, "H") 'copie la ligne J dans la cellule ligne PLV colonne H
            Exit For 'sort de la boucle 2
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
Next I 'prochaine plage de la boucle 1
End Sub

[Édition]
Bonjour Ikito, nos posts se sont croisés..

 

[Dranreb]

Bonjour.
Un peu plus court :

Option Explicit
Sub Boucle()
   Dim TE(), LE&, TS(), LS&, C&
   TE = Feuil1.[A1].Resize(Feuil1.[B1000000].End(xlUp).Row, 5).Value
   ReDim TS(1 To UBound(TE, 1), 1 To 4)
   LE = 1
   Do: LS = LS + 1: LE = LE + 1
      Do: If TE(LE, 5) > TS(LS, 4) Then For C = 1 To 4: TS(LS, C) = TE(LE, C + 1): Next C
         LE = LE + 1
         If LE > UBound(TE, 1) Then Exit Do
         Loop Until TE(LE, 1) <> ""
      Loop Until LE > UBound(TE, 1)
   Feuil1.[H6].Resize(UBound(TS, 1), 4).Value = TS
   End Sub

 

[sams96]

Bonjour à tous , je vous remercie pour vos réponse , mais je me suis peut etre mal exprimé
Ce que je recherche dans les colonnes H, I,J ,k , c est les 5 sous catégorie ayant la valeur la plus élevée dans la colonne E,
Par exemple , dans la catégorie "FTYy , ça sous catégorie PJAM à la première valeur la plus élevée de la colonne N donc on la sélectionne ,
dans la catégorie "LAM , çes sous catégorie LEL et CENI ont la 2 ème et 3 ème valeur la plus élevée de la colonne N donc on les sélectionne ,etc

Sans pour autant oublier que mon tableau est dynamique .

Je vous de m aider et je m'excuse d'avance du dérangement que cela peut vous occasionné

Vous trouverez ci joint le fichier excel avec les résultats que je recherche

essayer de détaillez les lignes de votre code je vous en supplie

 

[Dranreb]

Il peut donc y en avoir plusieurs d'un même paquet, du moment qu'il sont dans les 5 en tête dans la colonne E ?
Alors il ne faut pas tenir compte du tout de la colonne A. Classez tout en ordre décroissant sur la colonne E et n'en retenez que 5 !

 

[sams96]

Oui , vous avez raison , mais du coup on fait comment , je suis seulement débitant en vba

 

[Dranreb]

Enregistrez une nouvelle macro pour générer automatiquement un brouillon de code. Pendant que ça enregistre, copiez si vous voulez les colonnes B:E en H:K, puis classez en ordre décroissant sur K, supprimez les lignes qui ne sont plus dans ce top 5, arrêtez l'enregistrement de la macro et optimisez le code.

 

[job75]

Bonjour sams96, Ikito, Robert, Bernard,

Il suffisait de rester sur cet autre fil mais bon, voyez le fichier joint et la macro du bouton :

Private Sub CommandButton1_Click() 'bouton Maxima
Dim tablo, ub&, resu(), minimax#, i&, a(1 To 4), j&, n&
tablo = UsedRange.Resize(UsedRange.Rows.Count + 1, 5) 'matrice, plus rapide
ub = UBound(tablo)
ReDim resu(1 To ub, 1 To 4)
minimax = -10 ^ 99
For i = 1 To ub
    If tablo(i, 1) <> "" Then
        a(4) = minimax
        For j = i + 1 To ub
            If IsNumeric(CStr(tablo(j, 5))) And tablo(j, 5) > a(4) Then
                a(1) = tablo(j, 2): a(2) = tablo(j, 3)
                a(3) = tablo(j, 4): a(4) = tablo(j, 5)
            ElseIf tablo(j, 5) = "" Then
                If a(4) > minimax Then
                    n = n + 1
                    resu(n, 1) = a(1): resu(n, 2) = a(2)
                    resu(n, 3) = a(3): resu(n, 4) = a(4)
                End If
                i = j - 1
                Exit For
            End If
        Next j
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [H2] 'cellule à adapter
    If n Then .Resize(n, 4) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, 4).ClearContents 'RAZ en dessous
End With
End Sub

A+

 

[sams96]

Grace à vous , je peux passe à l'étape suivante de mon code
Je voudrais effectuer une boucle qui va remplacer ce code là :
wb.Sheets(1).Range("B16:B" & DLU).Copy wb.Sheets("ATTRIBUTION").Range("A1:A" & DLU)
wb.Sheets(1).Range("C16:C" & DLU).Copy wb.Sheets("ATTRIBUTION").Range("B1:B" & DLU)
wb.Sheets(1).Range("H16:H" & DLU).Copy wb.Sheets("ATTRIBUTION").Range("C1:C" & DLU)
wb.Sheets(1).Range("K16:K" & DLU).Copy wb.Sheets("ATTRIBUTION").Range("D1" & DLU)
wb.Sheets(1).Range("N16:N" & DLU).Copy wb.Sheets("ATTRIBUTION").Range("E1:E" & DLU)

Est ce qu'il serait possible de m'aider à réaliser cette boucle ?
Je vous remercie par avance .

 

[Ikito]

Sams96,

Peux-tu arrêter de multiplier les topics et les questions dans des topics qui n'ont rien à voir ?

Ta réponse ici.

 

[job75]

Par exemple , dans la catégorie "FTYy , ça sous catégorie PJAM à la première valeur la plus élevée de la colonne N donc on la sélectionne ,
dans la catégorie "LAM , çes sous catégorie LEL et CENI ont la 2 ème et 3 ème valeur la plus élevée de la colonne N donc on les sélectionne ,etc

Je n'avais pas vu ces explications mais si c'est bien cela que vous voulez il est évident que ma solution ne convient pas.

 

[job75]

Comme le disait Bernard il suffit de trier le tableau pour obtenir les Top 5, voyez le fichier joint et la macro du bouton :

Private Sub CommandButton1_Click() 'bouton Top 5
Application.ScreenUpdating = False
Intersect([B:E], UsedRange.EntireRow).Copy [H2]
Range("H2:K" & Rows.Count).Sort Columns("K"), xlDescending, Header:=xlNo
Range("H7:K" & Rows.Count).Delete xlUp 'RAZ
End Sub

 

[job75]

J'ai simplifié la macro précédente.