Amend the VBA code to Filter Columns Instead of Rows

[hrayani]

Hello Friends,

Some years back a gentleman here provided me the below code which works perfectly for filtering the rows with one or more criteria in a cell with comma separated values & not only this but also works with multiple entries like values in different cells

Can someone pls amend the code to work for Columns

Starting column would be Column D
Criteria would be added in cell B1:B3

rivate Const SRA As String = "A2:AO2" 'address  where you type the search criteria
Private Const dS As Long = 2  'row where you type the search criteria
Private Const dc As Long = 1  'First column of data
Private Const dr As Long = 4  'First row of data (exclude header)
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, J As Long, n As Long
Dim m As Long, p As Long
Dim r As Range
Dim arr, z, x

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

If Not Intersect(Target, Range(SRA)) Is Nothing Then
    n = Range(SRA).Resize(100000).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Application.ScreenUpdating = False
    Range("A" & dr & ":A" & n).EntireRow.Hidden = False

If WorksheetFunction.CountA(Range(SRA)) > 0 Then
        Rows(dS).AutoFit
    
        For Each r In Range(SRA)
        J = r.Column
            If Len(Cells(dS, J)) > 0 Then
                arr = Split(Cells(dS, J), ", ")
                For i = dr To n
                   z = Cells(i, J).Text
                   If z = "" Then Rows(i).EntireRow.Hidden = True
                   If Rows(i).RowHeight > 0 Then
                           m = 0
                       For Each x In arr
                            m = m + InStr(1, z, x, 1)
                            If m > 0 Then Exit For
                       Next
                           If m = 0 Then Rows(i).EntireRow.Hidden = True
                   End If
                Next
            End If
        Next
    Else
            Rows(dS).RowHeight = 35
       
            
    End If
End If

On Error Resume Next
p = Range("A" & dr & ":A" & n).SpecialCells(xlCellTypeVisible).Cells.Count
Application.StatusBar = "Found " & p & " rows"
On Error GoTo 0

ActiveWindow.ScrollRow = 1
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
End Sub

 

[Akuini]

@hrayani
Could you post some data to work with? If it's sensitive then just mock up some data.

 

[hrayani]

@hrayani
Could you post some data to work with? If it's sensitive then just mock up some data.

sure why not

Here is the data

Dashboard.xlsm
	B	C	D	E	F	G	H	I
1		Batch	2401	2701	2501	2401	2501	2401
2		Ref #	736	737	738	739	740	757
3		Supplier	SAAD	LAL	RAINBOW	RAINBOW	HOMECARE
Sheet1

Expected results with filter criteria in B1:B3 Example # 1

Dashboard.xlsm
	B	C					H	I
1		Batch					2501	2401
2	757	Ref #					757	757
3		Supplier					HOMECARE
Sheet1

Expected results with filter criteria in B1:B3 Example # 2

Dashboard.xlsm
	B	C					H
1		Batch					2501
2	757	Ref #					757
3	re	Supplier					HOMECARE
Sheet1

Expected results with filter criteria in B1:B3 Example # 3

Dashboard.xlsm
	B	C	D	E		G		I
1	24, 27	Batch	2401	2701		2401		2401
2		Ref #	736	737		739		757
3		Supplier	SAAD	LAL		RAINBOW
Sheet1

Expected results with filter criteria in B1:B3 Example # 2

Dashboard.xlsm
	B	C					H
1		Batch					2501
2	757	Ref #					757
3	re	Supplier					HOMECARE
Sheet1

Expected results with filter criteria in B1:B3 Example # 4

Dashboard.xlsm
	B	C		E
1	24, 27	Batch		2701
2	7	Ref #		737
3	L	Supplier		LAL
Sheet1

 

[Akuini]

Your question is a follow-up question from the previous thread:
vba-filter-codes-needs-amendment-to-filter-values-which-are-seperated-with-a-comma

I've modified the code I provided earlier to meet your new requirement. Here it is:"

Private Const SRA As String = "B1:B5" 'address  where you type the search criteria
Private Const dS As Long = 2  'column where you type the search criteria
Private Const dc As Long = 1  'First row of data
Private Const dr As Long = 4  'First column of data (exclude header)
Private Const max_n As Long = 10000  'maximum number of column that has data

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, j As Long, n As Long
Dim m As Long, p As Long
Dim r As Range
Dim arr, z, x

If Not Intersect(Target, Range(SRA)) Is Nothing Then
    Range("A1").Resize(, max_n).EntireColumn.Hidden = False
    n = Range(SRA).Resize(, max_n).Find("*", SearchOrder:=xlColumns, SearchDirection:=xlPrevious).Column
    Application.ScreenUpdating = False
    If WorksheetFunction.CountA(Range(SRA)) > 0 Then
        For Each r In Range(SRA)
            i = r.Row
            If Len(Cells(i, dS)) > 0 Then
                arr = Split(Cells(i, dS), ",")
                For j = dr To n
                   z = Cells(i, j).Text
                   If z = "" Then Columns(j).EntireColumn.Hidden = True
                   If Columns(j).EntireColumn.Hidden = False Then
                           m = 0
                       For Each x In arr
                            m = m + InStr(1, z, x, 1)
                            If m > 0 Then Exit For
                       Next
                           If m = 0 Then Columns(j).EntireColumn.Hidden = True
                   End If
                Next
            End If
        Next
    End If
    
    Application.ScreenUpdating = True

End If

On Error Resume Next
p = Range("A" & dr & ":A" & n).SpecialCells(xlCellTypeVisible).Cells.Count
Application.StatusBar = "Found " & p & " rows"
On Error GoTo 0
End Sub


Sub toClearFilter()
Dim n As Long
Range("A1").Resize(, max_n).EntireColumn.Hidden = False
Range(SRA).ClearContents

End Sub

Private Sub CommandButton1_Click()
Call toClearFilter
End Sub

The workbook, using previous example:
hrayani_-_Amend_the_VBA_code_to_Filter_Columns_Instead_of_Rows

 

[hrayani]

Thanks - Works like a Charm
Just curious to know what is the purpose of below part of the code

Private Const dc As Long = 1  'First row of data

 

[Akuini]

Thanks - Works like a Charm
Just curious to know what is the purpose of below part of the code

Private Const dc As Long = 1 'First row of data

Ah, you can remove it, it isn't used in the code, it's from the previous code.
How large is your dataset? Approximately how many cells does it contain? More than 10K?
If your dataset is large and you're experiencing any lag, I can probably adjust the code to make it faster.

 

[hrayani]

Ah, you can remove it, it isn't used in the code, it's from the previous code.
How large is your dataset? Approximately how many cells does it contain? More than 10K?
If your dataset is large and you're experiencing any lag, I can probably adjust the code to make it faster.

Thanks for a quick reply
I have removed that extra line
I dont see any lag in the code but would like to know which part of the code to change if any is been seen in future

is it the below part ??

Private Const max_n As Long = 10000  'maximum number of column that has data

Secondaly, instead of entering 10000 here, can't we tell the code to look at the last cell in row 1:3 starting from column D & adjust the range accordingly instead of 10000

 

[Akuini]

Secondaly, instead of entering 10000 here, can't we tell the code to look at the last cell in row 1:3 starting from column D & adjust the range accordingly instead of 10000

When there are hidden column, the FIND method isn't reliable for locating the last column with data. That's why the code needs to unhide all columns with data first before finding it. And that's why I set 10K columns, assuming all columns with data are within that range. This is addressed in this part:

    Range("A1").Resize(, max_n).EntireColumn.Hidden = False

After unhiding the 10K columns then the code will find last column with data in this part:

n = Range(SRA).Resize(, max_n).Find("*", SearchOrder:=xlColumns, SearchDirection:=xlPrevious).Column

I dont see any lag in the code but would like to know which part of the code to change if any is been seen in future

To speed up the code, we need to load the data into an array. However, if you haven't experienced any lag, then the code should be sufficient.

 

[hrayani]

Many Thanks!
This made my life easy

 

[Akuini]

You're welcome, glad to help & thanks for the feedback.