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
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

 

[Yongle]

One adjustment I'd like to make in it though. I put freeze panes in cell K15 in every single sheet. Rows 1-14 are always the date ranges/financial yr info/period start/end etc. and columns A-J are for any names, units etc etc

Test code below to see if it does what you want (filtering VBA willl be posted later)
- is row 14 the correct row for the header or should it be row 15?

Sub AddFlags()
    Const HdrRow = 14
    Const Flag = "Z"
    Const Hdrs = "A,B,C,D"
    Dim ws As Worksheet, lastRow As Long, cel As Range, HdrCols, HdrCol, RowCount As Long
    Set ws = ActiveSheet
    HdrCols = Split(Hdrs, ",")
    lastRow = ws.UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    RowCount = lastRow - HdrRow
'add default flag in column
    ws.Cells(HdrRow + 1, Flag).Resize(RowCount).Clear
    ws.Cells(HdrRow, Flag) = "STYLE"
    ws.Cells(HdrRow + 1, Flag).Resize(RowCount) = "Normal"
'overwrite flag if style is not "Normal"
    For Each HdrCol In HdrCols
        For Each cel In ws.Cells(HdrRow + 1, HdrCol).Resize(RowCount)
            With ws.Cells(cel.Row, Flag)
                If .Value = "Normal" Then .Value = cel.Style
            End With
        Next cel
    Next HdrCol
'filter dropdown
    ws.AutoFilterMode = False
    ws.Cells(HdrRow, Flag).AutoFilter
End Sub

 

[Yongle]

Filtering VBA will be ready for you to test after I tailor a few things to match your workbook.
I just need the following info from you...

1. Did code in post#11 achieve what you wanted?

2. Values from column Z
Hdr1 =
Hdr2 =
Hdr3 =

For info - details of my test values
Hdr1 = "60% - Accent1"
Hdr2 = "Accent2"
Hdr3 = "20% - Accent3"

3. Names of any sheets that should not be filtered
- assuming that you want ability to filter ALL sheets the same without setting each sheet separately

4. Is each Show/Hide button an Active-X Command Button or a Form Contol Button

 

[rahildhody]

This works brilliantly! Thank you! Row 15 is where the data/Heading1 starts from. The pane is freezed from until row 14. But the code above works perfectly.

 

[rahildhody]

Filtering VBA will be ready for you to test after I tailor a few things to match your workbook.
I just need the following info from you...

1. Did code in post#11 achieve what you wanted?

2. Values from column Z
Hdr1 =
Hdr2 =
Hdr3 =

For info - details of my test values
Hdr1 = "60% - Accent1"
Hdr2 = "Accent2"
Hdr3 = "20% - Accent3"

3. Names of any sheets that should not be filtered
- assuming that you want ability to filter ALL sheets the same without setting each sheet separately

4. Is each Show/Hide button an Active-X Command Button or a Form Contol Button

1) yep. works perfectly

2) Header 1 = "BS Header Main"
Header 2 = "BS Header Secondary"
Header 3 = "BS Header 3"

everything else = Normal

3) I want the "Show" and "Hide" buttons to be in every sheet.

4) I was going to make it into a 'Shape' and assign the macro to it. Currently that is what it is. But I'd prefer it to be a Form Control Button if it HAS to be a button as Active-X Command button stuffs my laptop up everytime for some odd reason


I'm a beginner/intermediate at vba so even if there are a few changes that I'd need to make later on (i.e. want to introduce a Header 4 or something), I THINK I'd be able to amend your code if it isn't too complicated. The initial code that I had posted was too advanced for my level, hence I wasnt able to amend it.

Thanks again for all your help! Really appreciate it!

 

[Yongle]

4) I was going to make it into a 'Shape' and assign the macro to it. Currently that is what it is. But I'd prefer it to be a Form Control Button if it HAS to be a button as Active-X Command button stuffs my laptop up everytime for some odd reason

You do not need to use an active-x command button and that is best avoided (you are not alone in experiencing problems)
A shape with macro assigned should be fine

After amending the VBA to include the values you posted (per post#14) , I will test the code with a shape before posting it

 

[rahildhody]

Great! Thank you!

 

[Yongle]

In summary when you click on a shape it runs macro ApplyFilter which (in turn) runs AddFlags before running FilterRows which filters based on the shape's text

To test this code
- delete any previous code
- paste the code below in a separate module
- modify any red value which needed modifying last time
- add a rectangle to the sheet (any shape will do - but I used a rectangle)
- you do not need to add any text to the shape
- assign macro ApplyFilter to the rectangle

The first time you click on the rectangle, sheet values are unfiltered and shape text becomes "Show Headers"
After that, filtering changes each time you click as does shape text

The code should function without a problem but is it filtering as required? (I would not be surprised if it isn't doing precisely what you want)
- let me know!

After the code is singing to your tune, I will provide detailed notes explaining everything and also how to modify things safely.

Option Explicit
    Private FlagRng As Range, FlagHdr As Range, ws As Worksheet
    Private Const HdrRow = [COLOR=#ff0000]14[/COLOR]
    Private Const Flag = "[COLOR=#ff0000]Z[/COLOR]"
    Private Const Hdrs = "  [COLOR=#ff0000]A[/COLOR]  , [COLOR=#ff0000]B[/COLOR] ,[COLOR=#ff0000]C[/COLOR],[COLOR=#ff0000]D[/COLOR] " 
    Private Const Hdr1 = "BS Header Main"
    Private Const Hdr2 = "BS Header Secondary"
    Private Const Hdr3 = "BS Header 3"
    
[COLOR=#800080]Sub ApplyFilter()[/COLOR]
    Set ws = ActiveSheet
    Call AddFlags
    Call FilterRows(ws.Shapes(Application.Caller).TextFrame.Characters.Text)
End Sub
   
[COLOR=#800080]Private Sub AddFlags()[/COLOR]
    Dim lastRow As Long, cel As Range, HdrCols, HdrCol, RowCount As Long
    HdrCols = Split(Hdrs, ",")
    lastRow = ws.UsedRange.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    RowCount = lastRow - HdrRow
    Set FlagRng = ws.Cells(HdrRow + 1, Flag).Resize(RowCount)
    Set FlagHdr = ws.Cells(HdrRow, Flag)
[I][COLOR=#006400]'add default flag in column[/COLOR][/I]
    FlagRng.Clear
    FlagHdr = "STYLE"
    FlagRng = "Normal"
[I][COLOR=#006400]'overwrite flag if style is not "Normal"[/COLOR][/I]
    For Each HdrCol In HdrCols
        For Each cel In ws.Cells(HdrRow + 1, HdrCol).Resize(RowCount)
            With ws.Cells(cel.Row, Flag)
                If .Value = "Normal" Then .Value = cel.Style
            End With
        Next cel
    Next HdrCol
End Sub

[COLOR=#800080]Private Sub FilterRows(HdrStyles As String)[/COLOR]
    Dim CritArray, rng As Range, shpTxt As String
    Set rng = Union(FlagHdr, FlagRng)
[I][COLOR=#006400]'new text for shape, create array of required filter values[/COLOR][/I]
    Select Case HdrStyles
        Case "Show Headers":        shpTxt = "Hide Header3":    CritArray = Array(Hdr1, Hdr2, Hdr3)
        Case "Hide Header3":        shpTxt = "Hide Header2":    CritArray = Array(Hdr1, Hdr2)
        Case "Hide Header2":        shpTxt = "Clear Filter":    CritArray = Array(Hdr1)
        Case Else:                  shpTxt = "Show Headers":    CritArray = Array("*")
    End Select
[I][COLOR=#006400]'filter and amend shape text[/COLOR][/I]
    ws.AutoFilterMode = False
    FlagHdr.AutoFilter
    rng.AutoFilter Field:=1, Criteria1:=CritArray, Operator:=xlFilterValues
    ws.Shapes(Application.Caller).TextFrame.Characters.Text = shpTxt
End Sub

 

[Yongle]

I just spotted that some spaces got into this line
- remove the spaces (probably happened when I changed the colour!)

Private Const Hdrs = "[COLOR=#ff0000]A[/COLOR],[COLOR=#ff0000]B[/COLOR],[COLOR=#ff0000]C[/COLOR],[COLOR=#ff0000]D[/COLOR]"

 

[rahildhody]

Hi Yongle,

Thanks for the code. I tested it but there's a small glitch in the code.

1st Click on the Blank Rectangle
- Text Changes to "Show Headers"
- Filters "*"

2nd Click on 'Show Headers'
- Text changes to "Hide Header3"
- Filters Header 3

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

4th Click on 'Hide Header2'
- Text changes to "Clear Filter"
- Filters Header 2

5th Click on "Clear Filter"
- same routine as 1st click on blank rectangle

and it then follows

Below is how it should be:

1st Click on the Blank Rectangle
- Text should change to "Hide Header 3"
- Filters "*"

2nd Click on 'Hide Header 3'
- Text should change to "Hide Header2"
- Filters Header 3

3rd Click on 'Hide Header2'
- Text should change to "Clear Filter"
- Filters Header 2

4th Click on 'Clear Filter'
- Text should change to "Hide Header3"
- Filters "*"

 

[rahildhody]

Here's another issue:

Not every sheet in my model has upto Header 3.

Some sheets only have Header 1 and Header 2, and some sheets have Header 3 as well. So the shape text does't make sense. Maybe I might remove the shape text code and call it a static "Hide"

Currently, let's say its filtered out Header 3 and showing only Header 1 and Header 2, I need to keep pressing the button until it gets to Clear Filter to make everything visible again. Would it be too hard to code 2 buttons "Show" and "Hide" and depending on what filter is on, it does the needful? i.e. If Header 3 is filtered and only showing Header 1 and Header 2 and I click on "Hide", it filters out header 2. But if I click on "Show" it adds Header 3 back to the filter.