Expand or contract Outline Groups within VBA code

Question

Is there a way to expand and collapse Groups defined using the Outline feature in Excel, from within VBA code?  I can't find anything in the on-line help, and Record Macro doesn't actually record such operations.

Thanks!

HJ

Moved from: (Office | Excel | Windows 10 | Office 2016)

Answer 1

Sub Example_ShowLevels()

  'Show all rows

  ShowLevels ActiveSheet.UsedRange, 1, , False

  'Hides all rows from level 2 (same as if you click on the "2" manually)

  ShowLevels ActiveSheet.UsedRange, 2, , True

End Sub

Sub ShowLevels( _

    Optional Where As Range = Nothing, _

    Optional ByVal RowLevels As Integer = 0, _

    Optional ByVal ColumnLevels As Integer = 0, _

    Optional ByVal HideLevels As Boolean = False)

  'Toggles individual outline levels

  'Note:

  '  On protected sheets you must allow format rows/columns!

  '  ActiveSheet.Protect AllowFormattingColumns:=True, AllowFormattingRows:=True

  Const MaxLevels = 8

  Dim Used As Range, Area As Range, r As Range

  Dim FromR As Range, ToR As Range

  Dim SaveScreenUpdating As Boolean

  SaveScreenUpdating = Application.ScreenUpdating

  Application.ScreenUpdating = False

  If Where Is Nothing Then

    On Error Resume Next

    With ActiveSheet.Outline

      If RowLevels > 0 Then .ShowLevels RowLevels:=IIf(HideLevels, RowLevels, MaxLevels)

      If ColumnLevels > 0 Then .ShowLevels ColumnLevels:=IIf(HideLevels, ColumnLevels, MaxLevels)

      GoTo ExitPoint

    End With

  End If

  On Error GoTo ExitPoint

  Set Used = Intersect(Where, ActiveSheet.UsedRange)

  For Each Area In Used.Areas

    If ColumnLevels > 0 Then

      For Each r In Area.Columns

        If r.EntireColumn.OutlineLevel >= ColumnLevels Then

          If FromR Is Nothing Then

            Set FromR = r.EntireColumn

          Else

            Set ToR = r.EntireColumn

          End If

        Else

          If Not ToR Is Nothing Then

            Application.Range(FromR, ToR).Hidden = HideLevels

            Set FromR = Nothing

            Set ToR = Nothing

          End If

        End If

      Next

      If Not ToR Is Nothing Then

        Application.Range(FromR, ToR).Hidden = HideLevels

        Set FromR = Nothing

        Set ToR = Nothing

      End If

    End If

    If RowLevels > 0 Then

      For Each r In Area.Rows

        If r.EntireRow.OutlineLevel > RowLevels Then

          If FromR Is Nothing Then

            Set FromR = r.EntireRow

          Else

            Set ToR = r.EntireRow

          End If

        Else

          If Not ToR Is Nothing Then

            Application.Range(FromR, ToR).Hidden = HideLevels

            Set FromR = Nothing

            Set ToR = Nothing

          End If

        End If

      Next

      If Not ToR Is Nothing Then

        Application.Range(FromR, ToR).Hidden = HideLevels

        Set FromR = Nothing

        Set ToR = Nothing

      End If

    End If

  Next

ExitPoint:

  Application.ScreenUpdating = SaveScreenUpdating

End Sub

Answer 2

Thanks very much, Andreas!

A lot more information than I actually needed, in the end, but certainly covered all the bases, and included what I was looking for.  I can also see how the parts I didn't need this time around could be helpful to me in the future, so thanks again.

Regards,

HJ