Expand all collapsed Outlines and restore them later
2013-08-07 Worksheets 0 334
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 FunctionBelow 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