XL 2010 Modification d'une macro grouper plan

Quincy

XLDnaute Occasionnel
Supporter XLD
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
 

Pièces jointes

  • Quincy-macro Groupe_A.xlsm
    21.8 KB · Affichages: 32

job75

XLDnaute Barbatruc
Bonjour Quincy, Lone-wolf,
Code:
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

XLDnaute Barbatruc
Re Quincy

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

tb.gif
 
Dernière édition:

Quincy

XLDnaute Occasionnel
Supporter XLD
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

XLDnaute Barbatruc
Re,

Une autre méthode, en s'appuyant sur la couleur de la cellule A2 et avec une fonction VBA :
Code:
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+
 

Pièces jointes

  • Quincy-macro Grouper(1).xlsm
    28 KB · Affichages: 29

Discussions similaires

Réponses
5
Affichages
165

Statistiques des forums

Discussions
311 720
Messages
2 081 915
Membres
101 838
dernier inscrit
Christelle.B86