Garder le dernier groupe de plan visible

STephane

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

XLDnaute Barbatruc
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...:rolleyes:)
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
 
Dernière édition:

STephane

XLDnaute Occasionnel
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".
 

Staple1600

XLDnaute Barbatruc
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
 
Dernière édition:

STephane

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

XLDnaute Barbatruc
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
 

Discussions similaires