XL 2010 Modification d'une macro grouper plan

[Quincy]

Bonjour à tous

J'aimerais modifier cette macro trouvée sur le forum (merci aux intervenants, ERIC S et jose.carreira) afin de l'adapter à mon fichier.
Voir fichier joint.

Merci pour votre aide.
Cordialement,

Quincy

 

[Lone-wolf]

Bonjour Quincy

Clique sur le bouton pour afficher le résultat. En souhaitant, bien évidemment, que ce soit ça que tu veux.

 

[job75]

Bonjour Quincy, Lone-wolf,

Sub Grouper()
Dim deb As Range, i&
Application.ScreenUpdating = False
Cells.ClearOutline 'RAZ
With [A1].CurrentRegion
    Set deb = .Cells(3, 1)
    For i = 4 To .Rows.Count + 1
        If .Cells(i, 1) <> .Cells(i - 1, 1) Then
            Range(deb, .Cells(i - 1, 1)).EntireRow.Group
            i = i + 1
            Set deb = .Cells(i, 1)
        End If
    Next
End With
ActiveSheet.Outline.ShowLevels RowLevels:=1
End Sub

A+

 

[Lone-wolf]

Bonjour job75 🙂

Mince, j'ai cru qu'il voulait reporter les données en colonne E.

 

[Quincy]

Bonjour Lone-Wolf, job75
Merci à vous deux pour vos réponses.

Lone-wolf, je clique sur le bouton mais il ne se passe rien, et je n'y vois pas de macro associée.

job75, j'ai lancé ta macro et j'ai le résultat souhaité.

Encore merci, cordialement.

Quincy

 

[Lone-wolf]

Re Quincy

@Quincy : comment ça il ne se passe rien?? 😵 J'ai cru que tu voulais reporter les données en colonne E.

 

[Quincy]

Re Lone-Wolf

Désolé, je viens de comprendre.
Je me suis mal exprimé lors de ma demande. En fait, la macro que lançais me mettait des boutons à développer sur la première ligne en dessous des lignes oranges et je ne savais pas la modifié.
Désolé si je t'ai froissé.
merci et bonne journée.

 

[job75]

Re,

Une autre méthode, en s'appuyant sur la couleur de la cellule A2 et avec une fonction VBA :

Sub Grouper()
If IsError(Application.Caller) Then Exit Sub 'sécurité
Dim a As Range, groupe As Boolean
Application.ScreenUpdating = False
Cells.ClearOutline 'RAZ
If ActiveSheet.DrawingObjects(Application.Caller).Text = "Grouper" Then
    With [A1].CurrentRegion.Columns(3) 'colonne auxiliaire
        .Formula = "=1/Couleur(A1,A$2)"
        On Error Resume Next 'si aucune SpecialCell
        For Each a In .SpecialCells(xlCellTypeFormulas, 16).Areas
            a.EntireRow.Group
        Next
        .Clear
    End With
    ActiveSheet.Outline.ShowLevels RowLevels:=1
    groupe = True
End If
ActiveSheet.DrawingObjects(Application.Caller).Text = IIf(groupe, "Dégrouper", "Grouper")
End Sub

Function Couleur(c As Range, ref As Range)
Couleur = c.Interior.Color = ref.Interior.Color
End Function

Fichier joint.

A+

 

[Quincy]

Bonjour le forum, bonjour job75

Je te remercie job75, je la mets sous le coude et je l'étudierai plus tard.
Cordialement.

Quincy

 

[Lone-wolf]

Bonjour Quincy, job75 🙂

@Quincy: pas besoin de t'excuser, tu ne ma pas froissé. 😉 Comme je l'ai dit, c'est moi qui a mal compris ta demande.