Macro to filter column containing values from list

[yanzers]

Hi all,

I'm looking for some help with a macro to filter a specific column containing values from a list on a separate tab.

Basically I have 2 sheets in my workbook:

• Sheet 1: contains a dynamic list of values that users need to copy/paste from a different source
• Sheet 2: contains a table of data, with column E (5) that needs to be filtered for all values contained in the list on sheet 1. This means exact matches and partial matches.

I got the below code to work for exact matches, but not partial matches. E.g. the list on sheet 1 contains "Belgium" and column E contains cells that have either "Belgium" (exact match) or "Belgium Netherlands" (partial match).

Any ideas how I can get this to work?

Thanks

Sub Filter_Scope()

Dim count As Integer
Dim list As Variant

Sheet1.Activate
count = WorksheetFunction.CountA(Range("A4", Range("A4").End(xlDown)))

list = Split(Join(Application.Transpose(Range(Cells(4, 1), Cells(count, 1)).Value), ","), ",")

Sheet2.Activate
ActiveSheet.Range("A1").Autofilter Field:=5, Criteria1:=list, Operator:=xlFilterValues

End Sub

 

[kevin9999]

One possibility, bit clunky, but seems to work.

Option Explicit
Sub Filter_Partial_Match()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")
    Set ws2 = Worksheets("Sheet2")
    Dim rData As Range, rCrit As Range, totCrit As Long
    Set rData = ws2.Range("A1").CurrentRegion
    
    ws1.Range("A4", ws1.Cells(Rows.Count, "A").End(xlUp)).Sort _
    Key1:=ws1.Range("A4"), order1:=xlAscending, Header:=xlYes
    
    totCrit = WorksheetFunction.CountA(ws1.Range("A3", ws1.Cells(Rows.Count, "A").End(xlUp)))
    Set rCrit = rData.Offset(, rData.Columns.Count).Resize(totCrit, 1)
    
    Dim arIn, i As Long
    arIn = ws1.Range("A4", ws1.Cells(Rows.Count, "A").End(xlUp))
    With rCrit
        .Cells(1) = ws2.Cells(1, 5).Value2
        For i = 1 To UBound(arIn)
            .Cells(1 + i) = "*" & arIn(i, 1) & "*"
        Next i
        With rData
            .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
        End With
        .Cells(1).EntireColumn.Delete
    End With
End Sub

With this on sheet 1:

Partial Match Filter.xlsm
	A	B
1
2
3	header
4	Belgium
5	England
6	USA
7
Sheet1

Turns this on sheet 2:

Partial Match Filter.xlsm
	A	B	C	D	E
1	HDR1	HDR2	HDR3	HDR4	HDR5
2	data	data	data	data	England UK
3	data	data	data	data	Wales
4	data	data	data	data	USA
5	data	data	data	data	USA Virgin Islands
6	data	data	data	data	England
7	data	data	data	data	Belgium
8	data	data	data	data	Belgium Netherlands
9	data	data	data	data	Australia
10	data	data	data	data	USA
11	data	data	data	data	Wales
12	data	data	data	data	Scotland
13	data	data	data	data	New England
Sheet2

Into this:

Partial Match Filter.xlsm
	A	B	C	D	E
1	HDR1	HDR2	HDR3	HDR4	HDR5
2	data	data	data	data	England UK
4	data	data	data	data	USA
5	data	data	data	data	USA Virgin Islands
6	data	data	data	data	England
7	data	data	data	data	Belgium
8	data	data	data	data	Belgium Netherlands
10	data	data	data	data	USA
13	data	data	data	data	New England
14
Sheet2

Let me know if this isn't what you were looking for.

 

[Peter_SSs]

@yanzers
I would strongly advise against using words that vba already has a special meaning for as variable, procedure or module names (eg your use of 'count' as a variable name).
I can lead to some significant problems.

In relation to your actual question, another Advanced Filter possibility is below.
I have assumed that column Z on Sheet2 can be used as a helper column.
It could be done with AutoFilter, but would require more work.

Sub AF_Special()
  Dim rCrit As Range
 
  Set rCrit = Sheets("Sheet2").Range("Z1:Z2")
  rCrit.Cells(2).Formula2 = Replace("=COUNT(SEARCH(Sheet1!A$4:A$#,E2)/(Sheet1!A$4:A$#<>""""))", "#", Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
  Sheets("Sheet2").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
  rCrit.Cells(2).ClearContents
End Sub

yanzers.xlsm
	A
1
2
3	List
4	Belgium
5	France
6	Spain
7
Sheet1

Before:

yanzers.xlsm
	A	B	C	D	E	F
1	Hdr1	Hdr2	Hdr3	Hdr4	Hdr5	Hdr6
2	a	data 1	x100	D2	Portugal	6
3	b	data 2	x101	D3	Spain	5
4	c	data 3	x102	D4	Belgium	8
5	d	data 4	x103	D5	Belgium Netherlands	9
6	e	data 5	x104	D6	Germany	5
7	f	data 6	x105	D7	Northern Spain	6
8
Sheet2

After:

yanzers.xlsm
	A	B	C	D	E	F
1	Hdr1	Hdr2	Hdr3	Hdr4	Hdr5	Hdr6
3	b	data 2	x101	D3	Spain	5
4	c	data 3	x102	D4	Belgium	8
5	d	data 4	x103	D5	Belgium Netherlands	9
7	f	data 6	x105	D7	Northern Spain	6
8
Sheet2

 

[Peter_SSs]

Not sure if it would suit your purpose but another possibility might be to create a separate table with the filtered values using a formula. Below I have done it in Sheet2 (columns J:O) but it could be in Sheet1 or a separate sheet.
Headings copied manually and formula only needs to go in the top-left cell (J2 in my example).

yanzers.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Hdr1	Hdr2	Hdr3	Hdr4	Hdr5	Hdr6				Hdr1	Hdr2	Hdr3	Hdr4	Hdr5	Hdr6
2	a	data 1	x100	D2	Portugal	6				b	data 2	x101	D3	Spain	5
3	b	data 2	x101	D3	Spain	5				c	data 3	x102	D4	Belgium	8
4	c	data 3	x102	D4	Belgium	8				d	data 4	x103	D5	Belgium Netherlands	9
5	d	data 4	x103	D5	Belgium Netherlands	9				f	data 6	x105	D7	Northern Spain	6
6	e	data 5	x104	D6	Germany	5
7	f	data 6	x105	D7	Northern Spain	6
8
Sheet2

Cell Formulas
Range	Formula
J2:O5	J2	=FILTER(A2:F7,BYROW(E2:E7,LAMBDA(r,COUNT(SEARCH(Sheet1!A$4:A$100,r)/(Sheet1!A$4:A$100<>"")))))
Dynamic array formulas.

 

[Peter_SSs]

It could be done with AutoFilter, but would require more work.

OK, to complete my three suggestions, here is an AutoFilter option to test.

Sub AutoFltr()
  Dim dIn As Object, dOut As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long
  Dim bFound As Boolean
  
  Set dIn = CreateObject("Scripting.Dictionary")
  dIn.CompareMode = 1
  Set dOut = CreateObject("Scripting.Dictionary")
  dOut.CompareMode = 1
  With Sheets("Sheet1")
    a = .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Sheet2")
    b = .Range("E2", .Range("E" & Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(b)
      If Not dIn.exists(b(i, 1)) Then
        If Not dOut.exists(b(i, 1)) Then
          j = 0
          bFound = False
          Do
            j = j + 1
            If InStr(1, b(i, 1), a(j, 1), vbTextCompare) > 0 Then
              dIn(b(i, 1)) = 1
              bFound = True
            End If
          Loop Until bFound Or j = UBound(a)
          If Not bFound Then dOut(b(i, 1)) = 1
        End If
      End If
    Next i
    If dIn.Count > 0 Then
      .Range("A1").CurrentRegion.AutoFilter Field:=5, Criteria1:=dIn.Keys, Operator:=xlFilterValues
    End If
  End With
End Sub

 

[yanzers]

OK, to complete my three suggestions, here is an AutoFilter option to test.

Sub AutoFltr()
  Dim dIn As Object, dOut As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long
  Dim bFound As Boolean
 
  Set dIn = CreateObject("Scripting.Dictionary")
  dIn.CompareMode = 1
  Set dOut = CreateObject("Scripting.Dictionary")
  dOut.CompareMode = 1
  With Sheets("Sheet1")
    a = .Range("A4", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  With Sheets("Sheet2")
    b = .Range("E2", .Range("E" & Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(b)
      If Not dIn.exists(b(i, 1)) Then
        If Not dOut.exists(b(i, 1)) Then
          j = 0
          bFound = False
          Do
            j = j + 1
            If InStr(1, b(i, 1), a(j, 1), vbTextCompare) > 0 Then
              dIn(b(i, 1)) = 1
              bFound = True
            End If
          Loop Until bFound Or j = UBound(a)
          If Not bFound Then dOut(b(i, 1)) = 1
        End If
      End If
    Next i
    If dIn.Count > 0 Then
      .Range("A1").CurrentRegion.AutoFilter Field:=5, Criteria1:=dIn.Keys, Operator:=xlFilterValues
    End If
  End With
End Sub

Hi @Peter_SSs,

Thanks for all these options! I tested all of them and this last one seems to be working the best in my case.

Also thanks for the tip on using words that vba already has a meaning for as variable. I'm very new to this, so tips like this will definitely help me down the line

Thanks again!

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.