Garder le dernier groupe de plan visible

STephane · 17 Septembre 2016

Bonsoir,

Je viens de créer un code pour masquer les groupes en colonne, à l'exception du dernier.
Cela utilise une autre fonction (laquelle contient la limitation à 255 colonnes)

Il y a peut-être plus simple mais je ne vais pas y passer la nuit ;-)

Code:

Sub Outline_Show_Ultimate_Group()
Dim rTarget As Range, rV As Range, rBuild As Range, aA As Areas, rStill As Range
Dim vResult As Variant
Dim wsh As Worksheet
Set wsh = ActiveSheet

Set rgTarget = ActiveSheet.UsedRange

' Loop on first row
For Each rV In rgTarget.Rows(1).Cells

  ' Find address of parent outline group
  Set vResult = Outline_InColumnAddress(rV)
   
  ' Build range object of outline groups
  If Not vResult Is Nothing Then _
  If rBuild Is Nothing Then Set rBuild = vResult Else Set rBuild = Union(rBuild, vResult)
Next rV

' Hide all groups
For Each rV In rBuild.Areas
rV.EntireColumn.Hidden = True
Next rV

' Redisplay the Ultimate Group
Set rStill = Range(rBuild.Areas(rBuild.Areas.Count).Address)
rStill.EntireColumn.Hidden = False
End Sub

Deuxième fonction

Code:

Public Function Outline_InColumnAddress(rngTest As Range) As Range
On Error Resume Next
Dim lOffset As Long
Dim lLevel As Long

lLevel = rngTest(1, 1).EntireColumn.outlineLevel
If lLevel = 1 Then GoTo TheExit

Do While rngTest(1, 1).Column > 1

If rngTest(1, 1).offset(0, -1).EntireColumn.outlineLevel = lLevel Then
Set rngTest = Union(rngTest, rngTest.offset(0, -1))
Else
Exit Do
End If
Loop

Do While rngTest(1, rngTest.Columns.Count).Column < 255

If rngTest(1, rngTest.Columns.Count).offset(0, 1).EntireColumn.outlineLevel = lLevel Then
Set rngTest = Union(rngTest, rngTest.offset(0, 1))
Else
Exit Do
End If
Loop
Set Outline_InColumnAddress = rngTest
TheExit:
Outline_InColumnAddress = False
End Function

HTH

Staple1600 · 18 Septembre 2016

Bonsoir à tous

STephane

STephane à dit:
Bonsoir,
Je viens de créer un code pour masquer les groupes en colonne, à l'exception du dernier.
Cela utilise une autre fonction (laquelle contient la limitation à 255 colonnes)

Ton code ressemble bigrement à celui de Robin Hammon, non ?
(code qui date de 2005...)
Tu as même laissé le HTH dans ton copié/collé
HTH= Hope That Helps

Public Function OutlineRange(rngTest As Range) As Range
Dim lOffset As Long
Dim lLevel As Long

'see if there is an outline at all
lLevel = rngTest(1, 1).EntireColumn.OutlineLevel
If lLevel = 1 Then Exit Function 'returns an empty range

Do While rngTest(1, 1).Column > 1

If rngTest(1, 1).Offset(0, -1).EntireColumn.OutlineLevel = lLevel Then
Set rngTest = Union(rngTest, rngTest.Offset(0, -1))
Else
Exit Do
End If
Loop

Do While rngTest(1, rngTest.Columns.Count).Column < 255

If rngTest(1, rngTest.Columns.Count).Offset(0,
1).EntireColumn.OutlineLevel = lLevel Then
Set rngTest = Union(rngTest, rngTest.Offset(0, 1))
Else
Exit Do
End If
Loop
Set OutlineRange = rngTest
End Function

HTH,

Robin Hammond

STephane · 18 Septembre 2016

La deuxième fonctio , oui, on dirait bien.

D'habitude je garde le nom de la macro originale et de l'auteur, mais cela m'est arrivé de supprimer les lignes de codes commentées par erreur certaines fois en manipulant les VBProjects ;-)

Cela fait donc peut-être 2 lustres qu'elle est dans mon "classeur personnel".

STephane · 18 Septembre 2016

le HTH c'est mon habitude, datant de mes heures passées sur les newsgroups anglophones.

Staple1600 · 18 Septembre 2016

Bonjour à tous

STephane
Si j'ai bien compris ce que tu veux faire, cette macro fait-elle la même chose?

VB:

Sub DernierGroupeVisible()
Dim i&, DerCol&, Groups$, rng As Range
Set rng = ActiveSheet.UsedRange: DerCol = rng.Columns.Count
For i = 1 To DerCol
If rng.Columns(i).OutlineLevel > 1 Then
Groups = Groups & " " & rng.Columns(i).Address(0, 0)
i = i + 1
End If
Next i
Columns(Range(Split(Groups)(UBound(Split(Groups)))).Column).ShowDetail = True
End Sub

EDITION: Ci-dessous macro pour tester la première macro

VB:

Sub MacroDeTEST()
With Range("A1:R111")
.Value = "=ROW()*COLUMN()"
.Value = .Value
End With
Columns("C:E").Columns.Group: Columns("H:K").Columns.Group: Columns("P:Q").Columns.Group
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
MsgBox "Afficher le dernier groupe?", vbOKOnly + vbQuestion, "Test"
Call DernierGroupeVisible
End Sub

STephane · 18 Septembre 2016

Super, et surtout plus compact ;-)
On peut facilement l'adapter pour fonctionner avec les groupes lignes.
La ligne suivante, présente dans la procédure "MacroDeTest" est nécessaire, ce qui me donne à la sortie cela:

Code:

Sub Outline_Show_Ultimate_Group()
' Original name: DernierGroupeVisible
'http://excel-downloads.com/threads/garder-le-dernier-groupe-de-plan-visible.20011300/#post-20084927
Dim i&, DerCol&, Groups$, rng As Range
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

Set rng = ActiveSheet.UsedRange: DerCol = rng.Columns.Count
For i = 1 To DerCol
  If rng.Columns(i).outlineLevel > 1 Then
  Groups = Groups & " " & rng.Columns(i).Address(0, 0)
  i = i + 1
  End If
Next i
Columns(Range(Split(Groups)(UBound(Split(Groups)))).Column).ShowDetail = True
End Sub

La première occurence tableau retourné est toutefois égale à "", ce qui poserait problème si à l'inverse on voulait afficher que le premier groupe (et non le dernier ;-).

Merci Staple

Staple1600 · 18 Septembre 2016

Re à tous

STephane
Il manquerait pas la ligne dont tu causes par hasard ?

La ligne suivante, présente dans la procédure "MacroDeTest" est nécessaire, ce qui me donne à la sortie cela:

EDITION: Autant pour moi, tu parlais de cette ligne, non ?

ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1

Staple1600 · 18 Septembre 2016

Re à tous

STephane
J'ai tenu compte de ta remarque

La première occurence tableau retourné est toutefois égale à "", ce qui poserait problème si à l'inverse on voulait afficher que le premier groupe (et non le dernier ;-).

Voir version corrigée de ma précédente macro

VB:

Sub mTEST()
Application.ScreenUpdating = False
MsgBox "Afficher détails du dernier groupe"
GroupeVisible 0
Application.ScreenUpdating = True
MsgBox "Afficher détails du premier groupe"
GroupeVisible 1
End Sub
Private Sub GroupeVisible(NumGroup As Integer)
Dim i&, DerCol&, Groups$, rng As Range
Set rng = ActiveSheet.UsedRange: DerCol = rng.Columns.Count
ActiveSheet.Outline.ShowLevels 0, 1
For i = 1 To DerCol
If rng.Columns(i).OutlineLevel > 1 Then
Groups = Groups & " " & rng.Columns(i).Address(0, 0)
i = i + 1
End If
Next i
Groups = Mid(Groups, 2, Len(Groups))
Select Case NumGroup
Case 0
'Dernier groupe visible
Columns(Range(Split(Groups)(UBound(Split(Groups)))).Column).ShowDetail = True
Case 1
'Premier groupe visible
Columns(Range(Split(Groups)(0)).Column).ShowDetail = True
End Select
End Sub

STephane · 18 Septembre 2016

Oui, je parlais bien de celle là.
Merci pour le tuning(ajustement) avec la fonction Mid

Garder le dernier groupe de plan visible

STephane

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

STephane

XLDnaute Occasionnel

STephane

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

STephane

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

STephane

XLDnaute Occasionnel

Discussions similaires