Filter the data table by column horizontally - Excel VBA

You can use Excel's filtering capabilities to select which rows in a data table are displayed. In other word, you can filter the data vertically using the built-in Excel functionality. But to my knowledge, you cannot filter the data table by column, which means that you cannot filter the data horizontally. This page discusses how to enable data to be filtered horizontally by column.

Filter data by column

1. Install Excel Addins Filter_heading.xlam

Donwload the Excel Add-in Filter_heading.xlam and install it referring to the page below.

Install Excel Add-in Add-in dialog

2. User Interface - RibbonX

Custom User interface is created using Custom UI editor. A new group Heading is added to the Data tab of the Excel standard Ribbon. You can visit the page below if you want to create your RibbonX user interface.

RibbonX User Interface Filter

3. Filter the selected columns

Selection of columns of your interest and filtering of the selected columns are implemented using the User Form. Select the Data tab on the Ribbon and press an Icon Column filter of the Heading. The userform is displayed below the cell $A$1 of the active worksheet containing the data table.

Filter and Sort Userform

3.1 Start program by pressing the Icon Column Filter.

The adopted RibbonX control is a Togglebutton with Pressed option. Pressing the Icon Column Filter triggers Userform and pressing again unloads the Userform.

	
Sub ToggleButton1_Click(control As IRibbonControl, pressed As Boolean)
    Application.ScreenUpdating = False
    If ActiveSheet.UsedRange Is Nothing Then
        Exit Sub
    End If
    ActiveSheet.Cells.EntireColumn.Hidden = False
    With ActiveSheet.UsedRange
        If .Columns.Count < 2 Then
            Exit Sub
        End If
    End With
    If pressed = True Then
        On Error Resume Next
        Application.ExecuteExcel4Macro "show.toolbar(""Ribbon"",true)"
        Application.WindowState = xlMaximized
        ActiveWindow.DisplayHeadings = True
        ActiveWindow.displayformulars = True
        With Application
            .CommandBars("Full Screen").Visible = True
            .CommandBars("Worksheet Menu Bar").Enabled = True
            .CommandBars("Standard").Visible = True
            .CommandBars("Formatting").Visible = True
        End With
        On Error GoTo 0
        
        With uf_FilterHeading
            .TextBox1.Text = ""
            .CheckBox1.Value = False
            .Label1.Enabled = False
            .Label2.Enabled = False
            Call UpdateControls_Filter
            .Show vbModeless
        End With
    ElseIf pressed = False Then
        Call uf_Unload
    End If
End Sub
			

3.2 Specify the row number representing the headings of the data table.

When the Textbox value is entered, call the procedure uf_Load.

			
Private Sub TextBox1_Change()
    If TextBox1.Text <> "" Then
        rh = Val(TextBox1.Text)
        Frame1.Enabled = True
        Call uf_Load(rh)
    Else
        Frame1.Enabled = False
    End If
    Call UpdateControls_Filter
End Sub
		

Unique headings of the data table are listed in the listbox in the ascending order..

Sub uf_Load(rh)
    Dim i As Integer, r As Long, c As Long
    Dim TempHeadings As Variant
    
    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    r = ws.Cells(Rows.Count, 1).End(xlUp).Row - rh + 1
    c = ws.Cells(rh, Columns.Count).End(xlToLeft).Column
    Erase Headings
    ReDim Headings(c)
    For i = 1 To c
        Headings(i) = ws.Cells(rh, i).Value
    Next
    TempHeadings = Headings
    TempHeadings = MysortProcedure(TempHeadings)
    Application.StatusBar = "Please wait...."
    With uf_FilterHeading
        With .ListBox1
            .Clear
            For i = 1 To UBound(TempHeadings)
                DoEvents
                If IsDate(TempHeadings(i)) Then
                    .AddItem Format(TempHeadings(i), DateFormat)
                Else
                    .AddItem TempHeadings(i)
                End If
            Next i
            .ListStyle = 1
            .MultiSelect = 1
        End With
        .Label1.Enabled = True
        .Label2.Enabled = True
        .CheckBox1.Value = False
        .CommandButton1.Enabled = True
    End With
    Application.StatusBar = False
End Sub
		

3.3 Select columns to be filtered using the Userform

Once Selection is made, OK button is enabled and press the OK button to run the sub procedure ColumnFilter.

Option Base 1
Option Compare Text
Private ws As Worksheet
Private Sub UserForm_Activate()
    Dim ATop As Double, ALeft As Double
    ATop = Application.Top
    ALeft = Application.Left
    With uf_FilterHeading
        .Top = ATop + 190
        .Left = ALeft + 19
    End With
End Sub
Private Sub CommandButton1_Click()
    Call ColumnFilter
End Sub
Private Sub CommandButton3_Click()
    Unload Me
End Sub
Private Sub TextBox1_Change()
    If TextBox1.Text <> "" Then
        rh = Val(TextBox1.Text)
        Frame1.Enabled = True
        Call uf_Load(rh)
    Else
        Frame1.Enabled = False
    End If
    Call UpdateControls_Filter
End Sub
Private Sub CheckBox1_Click()
    Dim i As Long
    Application.ScreenUpdating = False
    If CheckBox1.Value = True Then
        For i = 0 To ListBox1.ListCount - 1
            DoEvents
            ListBox1.Selected(i) = True
        Next i
    ElseIf CheckBox1.Value = False Then
        For i = 0 To ListBox1.ListCount - 1
            DoEvents
            ListBox1.Selected(i) = False
        Next i
    End If
    Call UpdateControls_Filter
End Sub
Private Sub ListBox1_change()
     Call UpdateControls_Filter
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
   If CloseMode = vbFormControlMenu Then
       MsgBox "Click the ""Close"" button to close the dialog"
       Cancel = True
   End If
End Sub

			

3.4 Filter the selected columns

Read the unselected columns and hide the unslected columns one by one from the backend. THis way, only the selected columns are visible.

Sub ColumnFilter()
    Dim i As Long, j As Long, n As Long
    Dim SelItems() As Variant, UnSelItems() As Variant
    Set ws = ActiveSheet
    
    ws.Cells.EntireColumn.Hidden = False

    Erase UnSelItems
    n = 0
    With uf_FilterHeading.ListBox1
        For i = 0 To .ListCount - 1
            If .Selected(i) = False Then
                n = n + 1
                ReDim Preserve UnSelItems(n)
                UnSelItems(n) = .List(i)
            End If
        Next i
    End With
    If n > 0 Then
        For i = UBound(Headings) To 2 Step -1
            For j = 1 To UBound(UnSelItems)
                If UnSelItems(j) = Headings(i) Then
                    ws.Cells(1, i).EntireColumn.Hidden = True
                End If
            Next j
        Next i
    End If
End Sub
			

4. Download Workbook

Download the Excel Addin and a demo file.

Download a Zip file with Excel Addin

Modified on:15-November-2019
Dated on: 13-October-2019