VBA code to filter a column by partial text match

[Indominus]

Hi. I have a VBA code where I filter a column by certain names. The names however, depending where I get them can have middle names on it whereas other just have last and first name. Example for one sheet would be Smith, John. Another could be
Smith, John Apple. In that format. How could I edit the VBA code to detect either one? I tried adding “*” in the code but it it still didn’t detect it. Also it might or might not have the space after the comma. Here is the part of the code I have right now. Works but only if it is exact. Thank you

      Dim manone As String, mantwo As String



         manone = Worksheets("Setup").Range("R3").Value

         mantwo = Worksheets("Setup").Range("R4").Value


        Columns("D:D").Select

        Application.CutCopyMode = False

        Selection.AutoFilter

        ActiveSheet.Range("D1").AutoFilter Field:=1, Criteria1:= _

        manone, Operator:=xlOr, Criteria2:=mantwo

 

[vcoolio]

Hello Indominus,

Perhaps:-

  Dim manone As String, mantwo As String



         manone = Worksheets("Setup").Range("R3").Value

         mantwo = Worksheets("Setup").Range("R4").Value


        'Columns("D:D").Select ' Don't need this line.

        Application.CutCopyMode = False

        'Selection.AutoFilter 'Don't need this line.

        ActiveSheet.Range("D1").AutoFilter Field:=1, Criteria1:="*" & manone & "*", Operator:=xlOr, Criteria2:="*" & mantwo & "*"

Cheerio,
vcoolio.

 

[Indominus]

Hello Indominus,

Perhaps:-

  Dim manone As String, mantwo As String



         manone = Worksheets("Setup").Range("R3").Value

         mantwo = Worksheets("Setup").Range("R4").Value


        'Columns("D:D").Select ' Don't need this line.

        Application.CutCopyMode = False

        'Selection.AutoFilter 'Don't need this line.

        ActiveSheet.Range("D1").AutoFilter Field:=1, Criteria1:="*" & manone & "*", Operator:=xlOr, Criteria2:="*" & mantwo & "*"

Cheerio,
vcoolio.

This one doesn’t recognize them at all

 

[Peter_SSs]

See how this one goes.

Sub AF()
  Dim d As Object
  Dim a As Variant
  Dim manone As String, mantwo As String
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.compareMode = 1
  manone = UCase(Split(Replace(Worksheets("Setup").Range("R3").Value, ", ", ","))(0)) & " *"
  mantwo = UCase(Split(Replace(Worksheets("Setup").Range("R4").Value, ", ", ","))(0)) & " *"
  With ActiveSheet
    .AutoFilterMode = False
    With .Range("D1", .Range("D" & Rows.Count).End(xlUp))
    a = .Value2
    For i = 2 To UBound(a)
      If UCase(Replace(a(i, 1), ", ", ",") & " ") Like manone Or UCase(Replace(a(i, 1), ", ", ",") & " ") Like mantwo Then
        d(a(i, 1)) = 1
      End If
    Next i
    .AutoFilter Field:=1, Criteria1:=Array(d.Keys), Operator:=xlFilterValues
    End With
  End With
End Sub

 

[Indominus]

See how this one goes.

Sub AF()
  Dim d As Object
  Dim a As Variant
  Dim manone As String, mantwo As String
  Dim i As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  d.compareMode = 1
  manone = UCase(Split(Replace(Worksheets("Setup").Range("R3").Value, ", ", ","))(0)) & " *"
  mantwo = UCase(Split(Replace(Worksheets("Setup").Range("R4").Value, ", ", ","))(0)) & " *"
  With ActiveSheet
    .AutoFilterMode = False
    With .Range("D1", .Range("D" & Rows.Count).End(xlUp))
    a = .Value2
    For i = 2 To UBound(a)
      If UCase(Replace(a(i, 1), ", ", ",") & " ") Like manone Or UCase(Replace(a(i, 1), ", ", ",") & " ") Like mantwo Then
        d(a(i, 1)) = 1
      End If
    Next i
    .AutoFilter Field:=1, Criteria1:=Array(d.Keys), Operator:=xlFilterValues
    End With
  End With
End Sub

Hi. So this gives me the error “Mismatch”. I just copied and pasted it over my previous part of code.

 

[Peter_SSs]

Hi. So this gives me the error “Mismatch”. I just copied and pasted it over my previous part of code.

That give me nothing to go on as the code worked fine on my test data.

Please give
- the full error
- which line of code produces the error
- confirm that the sheet to be filtered is the active sheet when this part of your full code is reached.

 

[Indominus]

Please give
- the full error
- which line of code produces the error
- confirm that the sheet to be filtered is the active sheet when this part of your full code is reached.

The line giving me the error is

.AutoFilter Field:=1, Criteria1:=Array(d.Keys), Operator:=xlFilterValues

Full code is this. Start of sub. Thank you by the way!

Application.ScreenUpdating = False



Sheets("Points").Select

Rows("1:1").Select

Selection.AutoFilter





'Set Cell Values as Variables for changing managers



Dim d As Object

Dim a As Variant

Dim manone As String, mantwo As String

Dim i As Long



Set d = CreateObject("Scripting.Dictionary")

d.CompareMode = 1

manone = UCase(Split(Replace(Worksheets("Setup").Range("R3").Value, ", ", ","))(0)) & " *"

mantwo = UCase(Split(Replace(Worksheets("Setup").Range("R4").Value, ", ", ","))(0)) & " *"

With ActiveSheet

.AutoFilterMode = False

With .Range("D1", .Range("D" & Rows.Count).End(xlUp))

a = .Value2

For i = 2 To UBound(a)

If UCase(Replace(a(i, 1), ", ", ",") & " ") Like manone Or UCase(Replace(a(i, 1), ", ", ",") & " ") Like mantwo Then

d(a(i, 1)) = 1

End If

Next i

.AutoFilter Field:=1, Criteria1:=Array(d.Keys), Operator:=xlFilterValues

End With

End With

 

[Peter_SSs]

Thanks. That code still works for me so must be something about the data or workbook.
One possibility is that there is nothing found to filter for so see what happens with this code.
I have rearranged and changed some parts a bit but just run it by itself as-is to start with please.
Let us know the result.

I'm guessing that you might find all rows on 'Points' hidden except for the header (assuming no error). If so, please advise what is in 'Setup' R3 and R4.

 

[Indominus]

Thanks. That code still works for me so must be something about the data or workbook.
One possibility is that there is nothing found to filter for so see what happens with this code.
I have rearranged and changed some parts a bit but just run it by itself as-is to start with please.
Let us know the result.

I'm guessing that you might find all rows on 'Points' hidden except for the header (assuming no error). If so, please advise what is in 'Setup' R3 and R4.

Hello. So upon testing this out it does work. My column for this is actually column U. I have a very similar code for column D so just accidentally put the wrong one. However, I am now running into two issues I did not foresee that break my whole code. I did not think it would affect it but I do have a code right after this one that will filter column G by numbers 13 or greater. This code line does not work anymore and when I try to put it in front of yours it erases the effect of your code.

Also the values in Setup R3 and R4 are the names I will use that I want to filter by. This file will be shared so that’s why I have it this way instead of in the code. My second issue is some of the names in the “Points” sheet have full names with the middle names and some might have long versions of first names. Such as “Williams,Samuel” instead of “Williams,Sam”. Or “Smith,Joshua”instead of “Smith, Josh”, etc. For example, the code is not detecting one where the file contains a name in the filter U column such as “Smith,Joshua Apple” but the value in R3 is Smith, Josh

How could I edit your code to be able to filter by numbers >= 13 and by other columns if I would need to? Also could that name issue be fixed? Thank you. Here is the full code for this sheet

Application.ScreenUpdating = False



Sheets("Points").Select

Rows("1:1").Select

Selection.AutoFilter



' Filter by man regardless of format



Dim d As Object

Dim a As Variant

Dim manone As String, mantwo As String

Dim i As Long



Set d = CreateObject("Scripting.Dictionary")

d.CompareMode = 1

manone = UCase(Split(Replace(Worksheets("Setup").Range("R3").Value, ", ", ","))(0)) & " *"

mantwo = UCase(Split(Replace(Worksheets("Setup").Range("R4").Value, ", ", ","))(0)) & " *"

With ActiveSheet

.AutoFilterMode = False

With .Range("U1", .Range("U" & Rows.Count).End(xlUp))

a = .Value2

For i = 2 To UBound(a)

If UCase(Replace(a(i, 1), ", ", ",") & " ") Like manone Or UCase(Replace(a(i, 1), ", ", ",") & " ") Like mantwo Then

d(a(i, 1)) = 1

End If

Next i

.AutoFilter Field:=1, Criteria1:=Array(d.Keys), Operator:=xlFilterValues

End With

End With







' Filter by greater than or equal to 13 and copy



ActiveSheet.Range("G1").AutoFilter Field:=7, Criteria1:= _

">=13", Operator:=xlAnd

Range("A1").Select

ActiveCell.CurrentRegion.Select

Selection.Copy



' Paste to Helper Points



Sheets("Helper Points").Select

Range("A1").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False



'Create Points Pivot Table
]

 

[Peter_SSs]

I have rearranged and changed some parts a bit but just run it by itself as-is to start with please.

But I forgot to post the code, sorry.
This is it and I have also changed the name filter column to U and included the >= 13 filter on column G.

Sub AF_v2()
  Dim d As Object
  Dim a As Variant
  Dim manone As String, mantwo As String
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  
  manone = UCase(Split(Replace(Worksheets("Setup").Range("R3").Value, ", ", ","))(0)) & " *"
  mantwo = UCase(Split(Replace(Worksheets("Setup").Range("R4").Value, ", ", ","))(0)) & " *"
  
  Application.ScreenUpdating = False
  With Sheets("Points")
    .AutoFilterMode = False
    With .Rows(1).Resize(.Range("U" & Rows.Count).End(xlUp).Row)
      a = .Columns(21).Value2
      For i = 2 To UBound(a)
        If UCase(Replace(a(i, 1), ", ", ",") & " ") Like manone Or UCase(Replace(a(i, 1), ", ", ",") & " ") Like mantwo Then
          d(a(i, 1)) = 1
        End If
      Next i
      If d.Count > 0 Then
        .AutoFilter Field:=21, Criteria1:=Array(d.Keys), Operator:=xlFilterValues
        .AutoFilter Field:=7, Criteria1:=">=13"
      Else
        .AutoFilter Field:=21, Criteria1:=""
      End If
    End With
    .Activate
  End With
  Application.ScreenUpdating = True
End Sub

This code will still have the "Josh" v "Joshua" issue which I had done deliberately. Only you know your data and requirements in detail but in my test data I have, among others, two males named "Smith, John" and "Smith, Joel" and two females named "Smith, Jonica" and "Smith, Jo"

If Setup!R3 = "Smith, Jo" then my code above will show only that name whereas the method you are suggesting would filter and show all four of those Smiths if they exist in 'Points'.
If you want to use your suggested method then simply remove these spaces near the end of the manone and mantwo lines.