Option Explicit
Private c As Range
Private rLastCell As Range
Private rHFilterRow As Range
Private i As Long
Private strFilter As String
Private bFilter As Boolean
Private lCalc As Long
Sub SetrHFilterRange()
On Error Resume Next
Application.ScreenUpdating = False
' Get the Last Cell of the Used Range
Set rLastCell = ThisWorkbook.Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell)
' Reset Range "rHFilter" from Cell C2 to last cell in Used Range
ThisWorkbook.Names.Add Name:="rHFilter", RefersTo:= _
"=Sheet1!$C$2:" & rLastCell.Address
For Each rHFilterRow In Range("rHFilter").Rows
With rHFilterRow
With Cells(.Row, 2)
.Value = "-"
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:="=""-"""
.FormatConditions(1).Interior.ColorIndex = 44
.Interior.ColorIndex = 22
End With
strFilter = "-"
i = 3
' Get the unique values in each row of rHFilter
' Then make a list with Data Validation
For Each c In .Cells
If Application.CountIf(Range(Cells(.Row, 3), _
Cells(.Row, i)), c.Value) = 1 Then
strFilter = strFilter & "," & c.Value
End If
i = i + 1
Next c
With Cells(.Row, 2).Validation
.Delete
.Add Type:=xlValidateList, Formula1:=strFilter & ",Blank Cells"
.InCellDropdown = True
End With
strFilter = ""
End With
Next rHFilterRow
For i = 1 To 4
Range(Cells(2, 1), rLastCell).Borders(i).LineStyle = xlContinuous
Next i
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
Sub SetrHFilter()
On Error Resume Next
ThisWorkbook.Sheets(1).Columns.Hidden = False
If Application.CountIf(ThisWorkbook.Sheets(1).Columns(2), "-") _
= Range("rHFilter").Rows.Count Then Exit Sub
If rLastCell Is Nothing Then
Set rLastCell = ThisWorkbook.Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell)
End If
' Speed the code up changing the Application settings
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
FilterRows:
' Hide columns if cells don't match the values in Column B
For Each rHFilterRow In Range("rHFilter").Rows
With rHFilterRow
If Cells(.Row, 2) <> "-" Then
For Each c In Range(Cells(.Row, 3), Cells(.Row, rLastCell.Column))
If Cells(.Row, 2).Value = "Blank Cells" Then
If c.Value <> "" Then c.EntireColumn.Hidden = True
Else
If c.Value <> Cells(.Row, 2).Value Then c.EntireColumn.Hidden = True
End If
Next c
End If
End With
Next rHFilterRow
If bFilter = False Then
bFilter = True
GoTo FilterRows
End If
' Change the Application settings back
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
Set rLastCell = Nothing
On Error GoTo 0
End Sub
Sub ResetrHFilter()
On Error Resume Next
ThisWorkbook.Sheets(1).Columns.Hidden = False
SetrHFilterRange
On Error GoTo 0
End Sub
