Filter another sheet by clicking the cell VBA

[rsj88]

Hi,


I have the below in Sheet1

Transport	Colour
Car	Red	Blue
Van	Green
Truck	Red	Blue	Yellow
Bike	200

Sheet 2 is as follows:

Colour	Cost
Red	1000
Green	400
Blue	200
Yellow	200

When i click on in sheet 1 on Call A2:A4 i want it to filter Sheet 2 Colour. A5(bike) needs to filter sheet 2 for cost

EG:

if i click car it will bring up sheet 2 filtered to red and blue. Van will just be green etc

Thanks in advance

 

[rsj88]

Any ideas guys?

 

[cmowla]

Questions to make this more clear to me (and maybe others):

• These colors are actual cell.interior.color (background colors) or the literal words that you wrote there?
• Are these Excel tables or just normal ranges with filters (or neither)? (See this post VBA Code - Date Filter for what I mean.)

 

[rsj88]

Hi

Colors are just words
These are not tables and are not ranges with filter

 

[cmowla]

Okay, right click on Sheet1's tab and click View Code

Copy the code below and paste into the window that comes up.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("A2:A5")) Is Nothing Then
        Cancel = True
        Call Filter_Sheet2(Target.row)
        Sheets("Sheet2").Select
    End If
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        Cancel = True
        Call Unfilter_Sheet2
    End If
End Sub

'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'    If Target.Cells.CountLarge > 1 Then Exit Sub
'    If Not Intersect(Target, Range("A2:A5")) Is Nothing Then
'        Call Filter_Sheet2(Target.row)
'        Sheets("Sheet2").Select
'    End If
'    If Not Intersect(Target, Range("A1")) Is Nothing Then
'        Call Unfilter_Sheet2
'    End If
'End Sub

Now in a standard code module

Copy the following code to any of them (or make a new one)

Sub Filter_Sheet2(clickedRowNumber As Long)
Dim lastUsedColumnNumber As Integer, lastRowNumber As Long
With ThisWorkbook.Sheets("Sheet1")
    lastUsedColumnNumber = .UsedRange.Columns.Count + .UsedRange.column - 1
End With
With ThisWorkbook.Sheets("Sheet2")
    lastRowNumber = .Cells(.Rows.Count, 1).End(xlUp).row
    .Range("1:1").AutoFilter

    Dim column As Integer, filterExp As String, allFilterExpressions As String
    allFilterExpressions = ""

    If (clickedRowNumber >= 2) And (clickedRowNumber <= 4) Then
        For column = 2 To lastUsedColumnNumber
            filterExp = ThisWorkbook.Sheets("Sheet1").Cells(clickedRowNumber, column).Value
            If Trim(filterExp) <> "" Then allFilterExpressions = allFilterExpressions & "," & filterExp
        Next column
        allFilterExpressions = Remove_String_Duplicates(Right(allFilterExpressions, Len(allFilterExpressions) - 1), ",")
        .Range("A1:B" & lastRowNumber).AutoFilter Field:=.Range("A1").column, Criteria1:="<>"
        .Range("A1:B" & lastRowNumber).AutoFilter Field:=.Range("A1").column, Criteria1:=Array(Split(allFilterExpressions, ",")), Operator:=xlFilterValues
        Exit Sub
    End If
    If clickedRowNumber = 5 Then
        For column = 2 To lastUsedColumnNumber
            filterExp = ThisWorkbook.Sheets("Sheet1").Cells(clickedRowNumber, column).Value
            If Trim(filterExp) <> "" Then allFilterExpressions = allFilterExpressions & "," & filterExp
        Next column
        allFilterExpressions = Remove_String_Duplicates(Right(allFilterExpressions, Len(allFilterExpressions) - 1), ",")
        .Range("A1:B" & lastRowNumber).AutoFilter Field:=.Range("B1").column, Criteria1:="<>"
        .Range("A1:B" & lastRowNumber).AutoFilter Field:=.Range("B1").column, Criteria1:=Array(Split(allFilterExpressions, ",")), Operator:=xlFilterValues
    End If
End With
End Sub

Sub Unfilter_Sheet2()
ThisWorkbook.Sheets("Sheet2").AutoFilterMode = False
End Sub

Sub Test__Remove_String_Duplicates()
Debug.Print Remove_String_Duplicates("Red,Red,Blue", ",")
End Sub
Function Remove_String_Duplicates(stringArray As String, delimiter As String)
'https://www.excelhow.net/how-to-remove-duplicates-in-one-cell-in-excel.html

'If there is no commas, there is only one entry.  And if there is only one entry, there is no duplicates.
If InStr(stringArray, delimiter) = 0 Then Remove_String_Duplicates = stringArray

Dim args() As String
args = Split(stringArray, delimiter)

Dim result As String
result = ""

Dim i As Long, j As Long, b As Boolean
For i = LBound(args) To UBound(args)
    b = False
    For j = i + 1 To UBound(args)
        If StrComp(args(i), args(j), vbBinaryCompare) = 0 Then
            b = True
            Exit For
        End If
    Next j
    If b = False Then result = result & delimiter & args(i)
Next i

Remove_String_Duplicates = Right(result, Len(result) - 1)

End Function

If you want to be able to conveniently navigate to Sheet1 from Sheet2 (such that, if you Double click on Cell A1 in Sheet2, it will bring you back to Sheet1, then right click on Sheet2's sheet tab (which there should be no code in it right now) and put this code in there.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Not Intersect(Target, Range("A1")) Is Nothing Then
        Cancel = True
        Call Sheets("Sheet1").Select
    End If
End Sub

'Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'    If Target.Cells.CountLarge > 1 Then Exit Sub
'    If Not Intersect(Target, Range("A1")) Is Nothing Then
'        Call Sheets("Sheet1").Select
'    End If
'End Sub

Now, Double click on Car, Van, Truck, or bike and see what happens to Sheet2.

Also, Double click on Cell A1 in Sheet1 ("Transport") to see that it will clear/lift the filters that were applied to Sheet2 from clicking on the previous vehicle type.

• If you want this to just be a single (left) click, in the first and last code blocks, I have commented out a single left click option. So uncomment that code and comment out the double click code. But I find for cell buttons, it's better to make them a double left click or a (single) right click.
• I know that you didn't have those arrow filters before, but they make things much faster. As you can see, as soon as VBA clears the filters, it also will remove/delete those arrows as well.

Let us know if this is what you wanted.

 

[rsj88]

@cmowla You got this bang on! works perfectly!! Thanks

 

[cmowla]

Thank you for the feedback. You are very welcome!