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