Expand all collapsed Outlines and restore them later

 2013-08-07    Worksheets    0    92

Sometimes your macro needs to unhide all rows/columns that are hidden using the outline functionality in a worksheet. That is quite easy to do, but usually the user will be quite unhappy that your macro has expanded the collapsed rows/columns. Below you will find a solution for storing all collapsed outlines in a worksheet, then you can expand them all, let your macro do it's business and finally restore the collapsed outlines again. Note: The example functions below assumes that your macro does not delete or add any rows/columns between storing the outline information and later resetting the collapsed outlines.

Function GetCollapsedOutlines(ws As Worksheet, Optional blnExpandAll As Boolean = False) As Collection
' updated 2013-08-07 by OPE
' returns a collection with information about the outlines that are collapsed
' returns Nothing if ws doesn't have an outline or no collapsed outlines where found
' if blnExpandAll = True then the function will expand all outlines in ws
Dim objOutline As Outline, lrn As Long, lcn As Long, i As Long
    If ws Is Nothing Then Exit Function
    
    On Error Resume Next
    Set objOutline = ws.Outline
    On Error GoTo 0
    If objOutline Is Nothing Then Exit Function
    
    Set GetCollapsedOutlines = New Collection
    With ws.UsedRange
        lrn = .Rows.Count
        lcn = .Columns.Count
    End With
    With ws
        Application.StatusBar = "Enumerating outlines in worksheet: " & .Name & "..."
        For i = 1 To lrn
            If Not .Rows(i).ShowDetail Then
                GetCollapsedOutlines.Add Array(True, i) ' save row number
            End If
        Next i
        For i = 1 To lcn
            If Not .Columns(i).ShowDetail Then
                GetCollapsedOutlines.Add Array(False, i) ' save column number
            End If
        Next i
        If blnExpandAll Then
            On Error Resume Next
            .Outline.ShowLevels 8, 8 ' expand all collapsed rows/columns
            On Error GoTo 0
        End If
    End With
    If GetCollapsedOutlines.Count = 0 Then Set GetCollapsedOutlines = Nothing ' no collapsed outlines
    Set objOutline = Nothing
    Application.StatusBar = False
End Function

Function CollapseOutlines(ws As Worksheet, coll As Collection) As Boolean
' returns False if ws doesn't have an outline or no collapsed outlines where found
' also returns False if restoring one or more collapsed outline fails
Dim objOutline As Outline, lrn As Long, lcn As Long, i As Long, OK As Boolean
    If ws Is Nothing Then Exit Function
    If coll Is Nothing Then Exit Function
    If coll.Count = 0 Then Exit Function
    If Not IsArray(coll(1)) Then Exit Function
    
    On Error Resume Next
    Set objOutline = ws.Outline
    On Error GoTo 0
    If objOutline Is Nothing Then Exit Function
    
    OK = True
    With ws
        Application.StatusBar = "Collapsing outlines in worksheet: " & .Name & "..."
        On Error GoTo ErrorCollapsingOutline
        .Outline.ShowLevels 8, 8 ' expand all collapsed rows/columns
        For i = 1 To coll.Count
            If coll(i)(0) Then
                .Rows(coll(i)(1)).ShowDetail = False ' collapse rows
            Else
                .Columns(coll(i)(1)).ShowDetail = False ' collapse columns
            End If
        Next i
        On Error GoTo 0
    End With
    Set objOutline = Nothing
    Application.StatusBar = False
    CollapseOutlines = OK
    Exit Function

ErrorCollapsingOutline:
    OK = False
    Resume Next
End Function
Below is a small example macro that shows how you can use the functions above:
Sub TestOutlineCollapsing()
Dim coll As Collection
Dim lrn As Long, lcn As Long
    ThisWorkbook.Activate
    Worksheets(1).Activate
    
    ' get collapsed outline levels and expand all outlines
    Set coll = GetCollapsedOutlines(ActiveSheet, True)
    If coll Is Nothing Then
        MsgBox "No outline or no collapsed levels found!", vbInformation
        Exit Sub
    End If
    
    ' do something
    MsgBox "All outline levels should now be visible!", vbInformation
    lrn = Range("A" & Rows.Count).End(xlUp).Row ' last used row in column A
    lcn = Cells(1, Columns.Count).End(xlToLeft).Column ' last used column in row 1
    
    ' restore the collapsed outline levels
    CollapseOutlines ActiveSheet, coll
    Set coll = Nothing
    Application.ScreenUpdating = True
    MsgBox "All outline levels should now be restored!", vbInformation
End Sub


Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.