Filtering Tables with Merged Cells to Show Whole Merged Cell

[atclaus]

I have often had tables with merged cells and I want to filter them but see all rows that are part of the merged cells. I wrote a macro to do this. I could not find something similar while Googling, so decided to post here for others.

I found a guide here that shows how to do it manually. I decided to automate it because macros are just better. You can either use this as a button or set to auto run anytime a cell is changed (may need some edits). Credit in the code below, but also "borrowed" some code on removing and reapplying AutoFilter code from here.

Module1

Option Explicit
'based upon guide at http://www.extendoffice.com/documents/excel/1955-excel-filter-merged-cells.html


Sub FilterMergedCellsFix()
Dim a, b, c, d As Integer
Dim ColumnsToFix, rng, OrigSelect As Range
Dim cl, rw, HRow, FRow, LRow, PCol, OrigSheet, TempSheet As Integer
Dim val As String
Dim HasFilter, UseFormulas As Boolean


Set OrigSelect = Selection


Set ColumnsToFix = Application.InputBox(Prompt:="Select header cell(s) of the column(s) with merged cells you wish to sort. These do not have to be next to each other.", _
    Title:="Select columns to fix", Default:=OrigSelect.Address, Type:=8)


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual


UseFormulas = True    'hardcoded option to determine how it fills in the cells, with values or formulas. Most cases this should be True, unless the sheet is very large and complicated then turn it to false


HasFilter = ActiveSheet.AutoFilterMode  'see if your sheet has a filter
If HasFilter Then Call RemoveAutoFilter 'pull and save your current filter settings


OrigSheet = ActiveSheet.Index
Sheets.Add after:=Sheets(OrigSheet)
TempSheet = ActiveSheet.Index
Sheets(OrigSheet).Activate


For a = 1 To ColumnsToFix.Areas.Count   'areas.count is the number of rangese of selected. This is 1 if you chose A1:D1, 2 if A1:B1 and C1
    With ColumnsToFix.Areas.Item(a)
        For cl = .Column To .Column + .Columns.Count - 1    'go through each column in each area
            HRow = .Row 'Header Row
            FRow = .Row + .Rows.Count   'First Row, .rows.count allows for a header that is merged cells (>1 row)
            
            Set rng = Range(Cells(ActiveSheet.Rows.Count, cl).Address).End(xlUp)    'last row in this column with data; if a merged cell and this macro has not changed it then this will be the first row of the merged cell
            LRow = rng.Row
            If rng.MergeCells = True Then
                If Cells(rng.Row + rng.Rows.Count - 1, cl) = "" Then
                    LRow = LRow + rng.MergeArea.Rows.Count - 1  'changes LRow to be the last row of the merged cell if needed
                End If
            End If
            
            Columns(cl).Copy
            Columns(cl).Copy    'need 2 copies for Excel 2013 sometimes
            Sheets(TempSheet).Columns(1).PasteSpecial Paste:=xlPasteFormats
            Range(Cells(FRow, cl), Cells(LRow, cl)).MergeCells = False  'unmerge the cells
            
            'Fill in the missing values for the merged cells empty spaces xxxxxxxxxxxx
            If UseFormulas Then
                On Error Resume Next    'turn off errors for when there are no blanks
                Range(Cells(FRow, cl), Cells(LRow, cl)).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"  'give all of the blank cells a formula equal to the cell above it
                On Error GoTo 0         'turn back on error handling
            Else
                val = ""    'the formula in the "merged" cell
                For rw = FRow To LRow
                    With Cells(rw, cl)
                        If .Formula <> "" Then
                            val = .Formula  'get the formula
                        Else
                            .Formula = val  'put the formula
                        End If
                    End With
                Next rw
            End If
            'Fill in the missing values for the merged cells empty spaces xxxxxxxxxxxx
            
            Sheets(TempSheet).Columns(1).Copy
            Sheets(TempSheet).Columns(1).Copy
            Columns(cl).PasteSpecial Paste:=xlPasteFormats
            Sheets(TempSheet).Columns(1).Clear  'clear formatting in the tempsheet
            'Columns(PCol).Clear
        Next cl
    End With
Next a


OrigSelect.Select   'reset the original user selection
Application.DisplayAlerts = False
Sheets(TempSheet).Delete    'delete the temp sheet that was created
Application.DisplayAlerts = True


If HasFilter Then Call ReapplyAutoFilter 'reset the user autofilter if was present


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub

Module2

Option Explicit
Dim w As Worksheet
Dim filterArray()
Dim currentFiltRange As String
Dim col, f As Integer
'based upon http://www.mrexcel.com/forum/excel-questions/333961-capture-autofilter-state.html
'added a line to reapply the autofilter even if no filtering was done


Sub RemoveAutoFilter()
    Set w = ActiveSheet
        With w.AutoFilter
            currentFiltRange = .Range.Address
            With .Filters
                ReDim filterArray(1 To .Count, 1 To 3)
                For f = 1 To .Count
                    With .Item(f)
                        If .On Then
                            filterArray(f, 1) = .Criteria1
                            If .Operator Then
                                filterArray(f, 2) = .Operator
                                filterArray(f, 3) = .Criteria2
                            End If
                        End If
                    End With
                Next f
            End With
        End With
    
    w.AutoFilterMode = False
End Sub


Sub ReapplyAutoFilter()
    Range(currentFiltRange).AutoFilter
    For col = 1 To UBound(filterArray(), 1)
        If Not IsEmpty(filterArray(col, 1)) Then
            If filterArray(col, 2) Then
                w.Range(currentFiltRange).AutoFilter Field:=col, _
                Criteria1:=filterArray(col, 1), _
                Operator:=filterArray(col, 2), _
                Criteria2:=filterArray(col, 3)
            Else
                w.Range(currentFiltRange).AutoFilter Field:=col, _
                Criteria1:=filterArray(col, 1)
            End If
        End If
    Next col
End Sub