Macro to Hide/Unhide rows based on Header Styles

[rahildhody]

Hi,

I'm trying to edit a macro to hide/unhide rows based on header styles.

What I currently have is a Show and Hide button on every sheet in the workbook that performs the below routine. What the routine does is if every single row is visible and the hide button is pressed once, then it hides everything except Header 1 and Header 2, and if the hide button is pressed the 2nd time, then it hides everything except Header 1. Similarly, it does the same thing when Show button is pressed.

What I'm trying to achieve if have a Header 3 in there as well. So if every single row is visible and the Hide button is pressed once, then it hides everything except Header 1, Header 2 and Header 3, if the Hide Button is pressed the 2nd time, then hides everything except Header 1 and Header 2 and when pressed the 3rd time, hides everything except Header 1.

Could someone please help me amend this code, or if there is a better way to execute what I'm trying to achieve, then I'm all ears!

Thank you for your help!

'ShowHideMaster is attached to buttons to show/hide all rows bar headers
'CycleSectionHiddenMaster is attached to the double click function to cycle through visibility options for a section
'Each of these master macros makes use of the following subroutines and functions:
'CycleSection performs the hiding/unhiding for a number of "to be" states
'SectionEndCell is a function to find the end of a section (i.e. the next time the same or higher level header is reached)
'SectionStatus returns the visibility status of the section, from all hidden to all visible through only headers visible, etc

Sub BSShowHide()
Dim FirstCell As Range
Dim IsProtected As Boolean

Const Header1Style As String = "BS Header Main"
Const Header2Style As String = "BS Header Secondary"
Const FakeStyle As String = "This is a fake style"


    Application.StatusBar = "Hiding/showing rows: please wait..."
    Application.ScreenUpdating = False

    Set FirstCell = Range("B15")
    Do While FirstCell.Style <> Header1Style
        Set FirstCell = FirstCell.Offset(1, 0)
        If FirstCell.Row > Cells.SpecialCells(xlCellTypeLastCell).Row Then
            GoTo TheEnd
        End If
    Loop

    If Application.Caller = "ShowButton" Then 'show button pressed
        Application.StatusBar = "Unhiding rows: please wait..."
        If SectionStatus(FirstCell, Cells.SpecialCells(xlCellTypeLastCell).Offset(-1, 0), Header1Style, Header2Style) = 1 Then
            'all hidden except first headers, so go to showing all headers
            Call CycleSection(FirstCell, Cells.SpecialCells(xlCellTypeLastCell), 2, Header1Style, Header2Style)
        Else
            'any other status, go to showing everything
            Call CycleSection(FirstCell, Cells.SpecialCells(xlCellTypeLastCell), 3, Header1Style, Header2Style)
        End If
    ElseIf Application.Caller = "HideButton" Then 'hide button pressed
        Application.StatusBar = "Hiding rows: please wait..."
        If SectionStatus(FirstCell, Cells.SpecialCells(xlCellTypeLastCell).Offset(-1, 0), Header1Style, Header2Style) = 4 Then
            'everything showing, so go to showing all headers
            Call CycleSection(FirstCell, Cells.SpecialCells(xlCellTypeLastCell), 2, Header1Style, Header2Style)
        Else
            'any other status, go to showing only first headers (by using a fake colour for second headers)
            Call CycleSection(FirstCell, Cells.SpecialCells(xlCellTypeLastCell), 2, Header1Style, FakeStyle)
        End If
    Else
        'procedure called not using buttons
        MsgBox "Invalid caller"
    End If

TheEnd:
    Application.ScreenUpdating = True
    Application.StatusBar = False
    Exit Sub


End Sub


Function SectionStatus(FirstCell As Range, LastCell As Range, Header1Style As String, Header2Style As String) As Integer
'sectionstatus=0 if not a section header
'sectionstatus=1 if everything is hidden except top level headers
'sectionstatus=2 if only and all headers are showing
'sectionstatus=3 if anything else...
'sectionstatus=4 if everything is visible
    
Dim SectionComplete As Boolean
Dim UpperLevelHiddenFound As Boolean
Dim UpperLevelVisibleFound As Boolean
Dim LowerLevelHiddenFound As Boolean
Dim LowerLevelVisibleFound As Boolean
Dim NoHeaderHiddenFound As Boolean
Dim NoHeaderVisibleFound As Boolean
Dim Counter As Long
Dim FirstCellStyle As String
Dim TheCell As Range 'index cell

    'set up variables
    FirstCellStyle = FirstCell.Style
    SectionComplete = False
    LowerLevelHiddenFound = False
    LowerLevelVisibleFound = False
    NoHeaderHiddenFound = False
    NoHeaderVisibleFound = False

    If FirstCellStyle <> Header1Style And FirstCellStyle <> Header2Style Then
        'initial cell is not a header
        SectionStatus = 0
    ElseIf FirstCell.Row = LastCell.Row Then
        'no section
        SectionStatus = 0
    Else
        'runs down rows to ascertain what is in the section
        Counter = 1
        Do While SectionComplete = False
            Set TheCell = FirstCell.Offset(Counter)
            If TheCell.Row > LastCell.Row Then
                SectionComplete = True
            ElseIf TheCell.Style = Header1Style Then
                If TheCell.EntireRow.Hidden = True Then
                    UpperLevelHiddenFound = True
                ElseIf TheCell.EntireRow.Hidden = False Then
                    UpperLevelVisibleFound = True
                End If
            ElseIf TheCell.Style = Header2Style Then
                If TheCell.EntireRow.Hidden = True Then
                    LowerLevelHiddenFound = True
                ElseIf TheCell.EntireRow.Hidden = False Then
                    LowerLevelVisibleFound = True
                End If
            Else
                If TheCell.EntireRow.Hidden = True Then
                    NoHeaderHiddenFound = True
                ElseIf TheCell.EntireRow.Hidden = False Then
                    NoHeaderVisibleFound = True
                End If
            End If
            Counter = Counter + 1
        Loop
    
        'determines status by what has been found in the section
        If NoHeaderVisibleFound = False And LowerLevelHiddenFound = False And UpperLevelHiddenFound = False Then
            SectionStatus = 2
        ElseIf NoHeaderVisibleFound = False And LowerLevelVisibleFound = False Then
            SectionStatus = 1
        ElseIf NoHeaderHiddenFound = False And LowerLevelHiddenFound = False And UpperLevelHiddenFound = False Then
            SectionStatus = 4
        Else
            SectionStatus = 3
        End If

    End If

End Function

Sub CycleSection(FirstCell As Range, LastCell As Range, NewStatus As Integer, Header1Style As String, Header2Style As String)
'cycles hidden/visible status of section
'NewStatus=1 hides everything
'NewStatus=2 hides everything except all section headers
'NewStatus=3 unhides everything
Dim VisibleRange As Range
Dim TheRow As Long
Dim LowerHeadersFound As Boolean

    Select Case NewStatus
        Case 1 'hide everything
            Range(FirstCell.Offset(1, 0), LastCell).EntireRow.Hidden = True
            FirstCell.EntireRow.Hidden = False
        Case 2 'unhide all lower section headers
            LowerHeadersFound = False
            Set VisibleRange = FirstCell.EntireRow
            'find section headers
            For TheRow = FirstCell.Offset(1, 0).Row To LastCell.Row
                If Cells(TheRow, 2).Style = Header2Style Or Cells(TheRow, 2).Style = Header1Style Then
                    LowerHeadersFound = True
                    Set VisibleRange = Union(VisibleRange, Cells(TheRow, 2).EntireRow)
                End If
            Next TheRow
            If LowerHeadersFound = False Then 'no subheaders
                Range(FirstCell, LastCell).EntireRow.Hidden = False
            Else 'subheaders exist
                Range(FirstCell.Offset(1, 0), LastCell).EntireRow.Hidden = True
                VisibleRange.EntireRow.Hidden = False
            End If
        Case 3
            Range(FirstCell, LastCell).EntireRow.Hidden = False
        Case Else
            'do nothing if something else has been passed
    End Select
    

End Sub



'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'End of Show/Hidefunctionality
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

 

[rahildhody]

Hi Yongle,

3rd Click on 'Hide Header3'
- Text changes to "Hide Header2"
- Filters nothing

Sorry, I take that back. I was testing the code with only Header 1 and Header 2. But when I tested it on the sheet with all 3 headers, it worked perfectly. So need to amend the code to look for how many headers the sheet has, and based on that, do what it needs to do.

 

[Yongle]

So you want one button ...
show All-> remove Normal-> remove Header3-> remove Header2-> show All-> etc
Other button...
show All-> show Header1-> add Header2-> add Header3-> show All etc

And you want VBA to work if some sheets contain 2 headers, others 3 headers, others 4 headers etc

I will look at this later today

 

[rahildhody]

yep. that's it!

Pretty much, both the buttons should work simultaneously and see what's filtered and what's pressed.

i.e.
- if all normal's are filtered out and i press "show" button, then it adds normal back
- if all header 3's are filtered out and i press "show" button, then it adds header 3 back and if i press "show" button again, then it adds normal back
- if all header 3's are filtered out and i press "hide" button, then it filters out header 2
etc.

And you want VBA to work if some sheets contain 2 headers, others 3 headers, others 4 headers etc

Yes please

 

[Yongle]

Again - REMOVE all previous code

After adding the VBA, assign macro ApplyFilter to both shapes ("Show" and "Hide")
- VBA uses shape text "Show" and "Hide"

Cell Styles in column Z have been replaced by NUMBERS
- makes it easier to filter in both directions
Code modified to allow up to 8 header styles (applied in order)
- declare each one with value "z" unless in use
- you can delete them if you prefer
- but also delete from AddFlags
All variables declared at the top of the module
- allows them to be used in all procedures
Message box added to report any Style Constants found in cells not declared in VBA
- when you add a new style in worksheet, add matching style constant

Option Explicit
    Private FlagRng As Range, FlagHdr As Range, ws As Worksheet, Msg As String
    Private LastRow As Long, Cel As Range, FlagCel As Range, HdrCols, HdrCol, RowCount As Long
    Private Kriteria As Long, k As Long
    Private Const HdrRow = [COLOR=#ff0000]14[/COLOR]
    Private Const Flag = "[COLOR=#ff0000]Z[/COLOR]"
    Private Const Hdrs = "[COLOR=#ff0000]A,B,C,D[/COLOR]"
    Private Const Hdr1 = "BS Header Main"
    Private Const Hdr2 = "BS Header Secondary"
    Private Const Hdr3 = "BS Header 3"
    Private Const Hdr4 = "z", Hdr5 = "z", Hdr6 = "z", Hdr7 = "z", Hdr8 = "z"

[COLOR=#006400] Sub ApplyFilter()[/COLOR]
    Set ws = ActiveSheet
    Call SetFlagRanges
    Call SetCriteria
    Call AddFlags
    Call FilterValues("<=" & Kriteria)
    If Msg > "" Then MsgBox "Add Style Constant in VBA - query styles found in rows.." & vbCr & Msg, , "Unexpected style found"
End Sub
   
[COLOR=#006400]Private Sub SetCriteria()[/COLOR]
[COLOR=#8b4513][I]'get current filter value[/I][/COLOR]
    On Error Resume Next                                    [I][COLOR=#8b4513]'current max[/COLOR][/I]
    Kriteria = WorksheetFunction.Max(FlagRng.SpecialCells(xlCellTypeVisible))
    If Err.Number > 0 Or Kriteria < 1 Then Kriteria = 1     'minimum value = 1
    On Error GoTo 0
    Call FilterValues("*")                                 [I][COLOR=#8b4513] 'clear previous filter[/COLOR][/I]
[COLOR=#8b4513]'get next filter value[/COLOR]
    If ws.Shapes(Application.Caller).TextFrame.Characters.Text = "Hide" Then
        If Kriteria > 1 Then Kriteria = Kriteria - 1       [I][COLOR=#8b4513] 'default = reduce by 1[/COLOR][/I]
    ElseIf ws.Shapes(Application.Caller).TextFrame.Characters.Text = "Show" Then
        For k = Kriteria To 9                               'does next value exist?
            If WorksheetFunction.CountIf(FlagRng, k + 1) > 0 Then
                Kriteria = k + 1                            [I][COLOR=#8b4513]'default = increase by 1[/COLOR][/I]
                k = 9                                       [COLOR=#8b4513]'controlled exit from loop[/COLOR]
            Else
                If k > 7 Then
                    Kriteria = 9                           [I] [COLOR=#8b4513]'max value = 9[/COLOR][/I]
                    k = 9                                  [I] [COLOR=#8b4513]'controlled exit from loop[/COLOR][/I]
                End If
            End If
        Next k
    End If
[COLOR=#006400]End Sub[/COLOR]

[COLOR=#006400]Private Sub SetFlagRanges()[/COLOR]
    LastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    RowCount = WorksheetFunction.Max(LastRow - HdrRow, 1)
    Set FlagRng = ws.Cells(HdrRow + 1, Flag).Resize(RowCount)
    Set FlagHdr = ws.Cells(HdrRow, Flag)
[COLOR=#006400]End Sub[/COLOR]

[COLOR=#006400]Private Sub AddFlags()[/COLOR]
    Msg = ""
    FlagRng.Clear
    FlagHdr = "STYLE"
    FlagRng = 9
'add numeric flag
    HdrCols = Split(Hdrs, ",")
    For Each HdrCol In HdrCols
        For Each Cel In ws.Cells(HdrRow + 1, HdrCol).Resize(RowCount)
        Set FlagCel = ws.Cells(Cel.Row, Flag)
            If Cel.Style <> "Normal" Then
                Select Case Cel.Style
                    Case Hdr1:  FlagCel = 1
                    Case Hdr2:  FlagCel = 2
                    Case Hdr3:  FlagCel = 3
                    Case Hdr4:  FlagCel = 4
                    Case Hdr5:  FlagCel = 5
                    Case Hdr6:  FlagCel = 6
                    Case Hdr7:  FlagCel = 7
                    Case Hdr8:  FlagCel = 8
                    Case Else:  Msg = Msg & " " & Cel.Row
                End Select
            End If
        Next Cel
    Next HdrCol
[COLOR=#006400]End Sub[/COLOR]

[COLOR=#006400]Private Sub FilterValues(myCriteria As String)[/COLOR]
    ws.AutoFilterMode = False                              [I][COLOR=#8b4513] 'show all data before filtering[/COLOR][/I]
    Call SetFlagRanges
    FlagHdr.AutoFilter
    Union(FlagHdr, FlagRng).AutoFilter Field:=1, Criteria1:=myCriteria, Operator:=xlFilterValues
[COLOR=#006400]End Sub[/COLOR]

 

[rahildhody]

Hi Yongle,

This works brilliantly! Thank you so much for all your help. I'm going to play around with it for a day or two and if it breaks will let you know. But so far, works perfectly fine!

 

[rahildhody]

Hi Yongle,

I tried this code all day yesterday and the only time it throws an error in line

[COLOR=#333333]FlagHdr.AutoFilter[/COLOR]

in Private Sub FilterValues is when I first set up a new sheet and Column Z doesn't have any values/filters. I tried putting in

On Error GoTo Next

right before the line but it doesn't seem to do the job. Currently the only way around it is if i bring in Header Name (STYLE) in cell Z14 and dummy values in cells Z15-16 and apply a filter on Z14. Any way to get around it?

 

[Yongle]

try this

On Error Resume Next
FlagHdr.AutoFilter
Union(FlagHdr, FlagRng).AutoFilter Field:=1, Criteria1:=myCriteria, Operator:=xlFilterValues
On Error GoTo 0

 

[rahildhody]

Perfect. Works now

Thank you so much for your help!