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

 

[Indominus]

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.

View attachment 39263

Hello. First off thank you again. So I been testing this out and it works for the number 13 filter and still filters by names but only if it matches by same name. Comma placement is no longer is a factor though.

One thing though is like you said I wouldn’t want to show all those names if people have the same last name and very similar first name. So I added in a line to filter column T by my work name so it only pulls names from my site which is all I care about (Points has names from the entire network of employees). This will obviously shrink the list.

So I then edited your code like you said by removing those two spaces but that is not working. Maybe it’s the type of name. Without giving away the name it’s tough but I’ll give the best example I can give. The name I have in Setup R3 or R4 is something like
Jones, Lily. Whereas in “Points” it is
like Jones, Liliana Angela. Last name will always be the same. Not sure what my options are as in Points it lists full names of employees and in Setup they will can be shortened names as employees at my job can also have preferred names on file. However, since I am now filtering by my site and there are not too many names, the chances of having the same last name and very similar first name should be rare.

 

[Peter_SSs]

employees at my job can also have preferred names on file.

Then you are likely to have serious problems if trying to use anything more than last name. After all, Robert Jones is quite possible to have a preferred name of "Bob", Alfred could be Fred and Richard could be D i c k (spaces required to avoid the automatic censor )

Certainly there is no obvious way for Excel to think that Lily is the same person as Liliana.

Have you considered making R3 and R4 on Setup use data validation so that users are forced to choose from a specified list of "correct" names?

 

[Indominus]

Then you are likely to have serious problems if trying to use anything more than last name. After all, Robert Jones is quite possible to have a preferred name of "Bob", Alfred could be Fred and Richard could be D i c k (spaces required to avoid the automatic censor )

Certainly there is no obvious way for Excel to think that Lily is the same person as Liliana.

Have you considered making R3 and R4 on Setup use data validation so that users are forced to choose from a specified list of "correct" names?

I did not actually. This would not work for me fully though as I am not sure what the full names would possibly be. Although I will use this just to avoid misspellings and all of that.

So I guess then since I am filtering by my site how could I edit this to use the last name and the first 3 letters of the first name? I believe that will work. Every single one I have seen have at least the same first 3 characters of the first names. If it doesn’t work for a couple of way different preferred names so be it. Thank you!

 

[Peter_SSs]

So I guess then since I am filtering by my site how could I edit this to use the last name and the first 3 letters of the first name?

Try this

Sub AF_v3()
  Dim d As Object
  Dim a As Variant
  Dim manone As String, mantwo As String, s As String
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  
  manone = Replace(Worksheets("Setup").Range("R3").Value, ", ", ",")
  manone = IIf(Len(manone) > 0, UCase(Left(manone, InStr(1, manone, ",") + 3)), "@") & "*"
  mantwo = Replace(Worksheets("Setup").Range("R4").Value, ", ", ",")
  mantwo = IIf(Len(mantwo) > 0, UCase(Left(mantwo, InStr(1, mantwo, ",") + 3)), "@") & "*"
  
  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)
        s = UCase(Split(a(i, 1), ",")(0) & "," & Left(Trim(Split(a(i, 1), ",")(1)), 3))
        If s Like manone Or s Like mantwo Then d(a(i, 1)) = 1
      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

 

[Indominus]

Try this

Sub AF_v3()
  Dim d As Object
  Dim a As Variant
  Dim manone As String, mantwo As String, s As String
  Dim i As Long
 
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
 
  manone = Replace(Worksheets("Setup").Range("R3").Value, ", ", ",")
  manone = IIf(Len(manone) > 0, UCase(Left(manone, InStr(1, manone, ",") + 3)), "@") & "*"
  mantwo = Replace(Worksheets("Setup").Range("R4").Value, ", ", ",")
  mantwo = IIf(Len(mantwo) > 0, UCase(Left(mantwo, InStr(1, mantwo, ",") + 3)), "@") & "*"
 
  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)
        s = UCase(Split(a(i, 1), ",")(0) & "," & Left(Trim(Split(a(i, 1), ",")(1)), 3))
        If s Like manone Or s Like mantwo Then d(a(i, 1)) = 1
      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

Works perfectly!!! Thank you so much Peter! I really appreciate it. Take care

 

[Peter_SSs]

Good news! Glad we got there in the end. Thanks for the follow-up.