Garder le dernier groupe de plan visible

[STephane]

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 ;-)

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

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]

Bonsoir à tous

STephane

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]

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]

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

 

[Staple1600]

Bonjour à tous

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

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

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]

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:

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]

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]

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

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]

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