Add wild cards to Filter

Question

I currently have 7 search fields (A1:G2) which the user can type in characters to filter a dataset right below it (A4:P16013).

I want to tweak the code to add a wild card (*) before and after every phrase inputted into the search field.

For example, if the user inputs "Toronto", I want to the code to search for "* Toronto *" (without the spaces).

This question is different from the links provided as I want the wild cards not to be restricted to certain phrases, but flexible for any phrase the user may input

How may I tweak my code below to do that?

Sub SearchAStore()
  Dim sh As Worksheet, lastRow As Long
  Set sh = ActiveSheet ' use here your sheet
  lastRow = sh.Range("A" & Rows.Count).End(xlUp).Row
    sh.Range("A4:O" & lastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=sh.Range("A1:G2")
End Sub

https://stackoverflow.com/questions/29820896/auto-filter-with-multiple-wildcards — Michal Rosa, Jun 22 '20 at 05:57
Does this answer your question? [Auto filter with multiple wildcards](https://stackoverflow.com/questions/29820896/auto-filter-with-multiple-wildcards) — Michal Rosa, Jun 22 '20 at 05:57
No, it does not. in the answer it helps to add wild cards to specific words, but I want to add wild cards to whichever words the user may type. — Hashmat Habibzadah, Jun 22 '20 at 06:00
Use the concatenate or & to join the "*" with the variable once it has been initiialized. — Solar Mike, Jun 22 '20 at 06:12
Or perhaps run a `replace(strFilter, " ", "* *")` to put a wildcard before and after all spaces in the filter string? You'd need a separate action for putting one at the start and end of the string but that wouldn't be hard — Spencer Barnes, Jun 22 '20 at 06:55
@Ron Rosenfeld: Yes, indeed... Now I can see that it is about `AdvancedFilter`. I will delete my comment. Thanks! — FaneDuru, Jun 22 '20 at 10:50

score 1 · Answer 1 · answered Jun 22 '20 at 06:54

1

Add the wildcards to the criteria range, filter, then remove the wildcards.

For example:

Dim sh As Worksheet, rngCrit As Range, c As Range
Set sh = ActiveSheet

Set rngCrit = sh.Range("B2:F3")
For Each c In rngCrit.Rows(2).Cells
    If Len(c.Value) > 0 Then c.Value = "*" & c.Value & "*"
Next c

sh.Range("B5:F18").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCrit

For Each c In rngCrit.Rows(2).Cells
    If Len(c.Value) > 0 Then c.Value = Mid(c.Value, 2, Len(c.Value) - 2)
Next c

answered Jun 22 '20 at 06:54

Tim Williams

154,628
8
97
125

(1) You can *update your question* to add code - it's too hard to read in a comment (2) "this gives me an error" is not a really useful description of what happens when you run that. *What error do you get, and on which line?* – Tim Williams Jun 22 '20 at 15:26
Sorry. Will fix. – Hashmat Habibzadah Jun 22 '20 at 15:56

VBasic2008 · Accepted Answer · 2021-01-30T14:22:23.027

AutoFilter feat. Wild Card Replacements

Copy the complete code into a standard module (e.g. Module1).
Adjust the constants in SearchAStore including the workbook.
Only run SearchAStore, the rest is being called.

The Code

Option Explicit

Sub SearchAStore()
    
    Const wsName As String = "Sheet1"
    Const CritAddr As String = "A1:G2"
    ' The following line represents the n-th column of the Filter Range,
    ' not necessarily the n-th column of the worksheet or the Criteria Range.
    ' If Filter Range would start in column "B" and you want to define
    ' the Last Row Column using column "B", the value remains 1.
    Const LastRowCol As Long = 1
    Const FirstRow As String = "A4:O4"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Define Filter Range.
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim rng As Range
    Set rng = ws.Columns(ws.Range(FirstRow).Columns(LastRowCol).Column)
    Set rng = rng.Find("*", , xlFormulas, , , xlPrevious)
    If rng Is Nothing Then Exit Sub
    If rng.Row < ws.Range(FirstRow).Row Then Exit Sub
    Set rng = ws.Range(FirstRow).Resize(rng.Row - Range(FirstRow).Row + 1)
    
    ' Define Criteria Range.
    Dim rngCrit As Range: Set rngCrit = ws.Range(CritAddr)
    
    wrapRange rngCrit.Rows(2), "*"
    rng.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCrit
    wrapRange rngCrit.Rows(2), "*", , True

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Adds or removes a string (wString) as a prefix, as a suffix    '
'               or as both to all string values in cells of a range.           '
' Inputs                                                                       '
'   DataRange     The Range (Object).                                          '
'   wString       The Wrap String i.e. the string to be added or removed.      '
'   Left1Right2   0 - Wrap String will be added or removed as both,            '
'                     prefix and suffix.                                       '
'                 1 - Wrap String will be added as prefix (in front of).       '
'                 2 - Wrap String will be added as suffix (behind).            '
'   removeWrap    False - Wrap String will be added.                           '
'                 True  - Wrap String will be removed.                         '
' Remarks:      When adding, if either prefix, suffix or both already exist,   '
'               they will not be added. When adding or removing only one,      '
'               the other will not be checked if it exists.                    '
' Precedents:   wrapString                                                     '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub wrapRange(DataRange As Range, _
              ByVal wString As String, _
              Optional ByVal Left1Right2 As Long = 0, _
              Optional ByVal removeWrap As Boolean = False)
    
    Dim cel As Range, Curr As String
    Dim Data As Variant: Data = DataRange.Value
    If Not IsArray(Data) Then
        If VarType(Data) = vbString Then
            DataRange.Value = wrapString(Data, wString, Left1Right2, removeWrap)
            Exit Sub
        End If
    End If
    Dim i As Long, j As Long
    For i = 1 To UBound(Data)
        For j = 1 To UBound(Data, 2)
            Curr = Data(i, j)
            If VarType(Curr) = vbString Then
                Curr = wrapString(Curr, wString, Left1Right2, removeWrap)
                Data(i, j) = Curr
            End If
        Next j
    Next i
    DataRange.Value = Data
        
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Adds or removes a string (wString) as a prefix, as a suffix    '
'               or as both to a string (aString).                              '
' Returns:      A string.                                                      '
' Inputs                                                                       '
'   aString       The initial string.                                          '
'   wString       The Wrap String i.e. the string to be added or removed.      '
'   Left1Right2   0 - Wrap String will be added or removed as both,            '
'                     prefix and suffix.                                       '
'                 1 - Wrap String will be added as prefix (in front of).       '
'                 2 - Wrap String will be added as suffix (behind).            '
'   removeWrap    False - Wrap String will be added.                           '
'                 True  - Wrap String will be removed.                         '
' Remarks:      When adding, if either prefix, suffix or both already exist,   '
'               they will not be added. When adding or removing only one,      '
'               the other will not be checked if it exists.                    '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function wrapString(ByVal aString As String, _
                    ByVal wString As String, _
                    Optional ByVal Left1Right2 As Long = 0, _
                    Optional ByVal removeWrap As Boolean = False) _
         As String
    
    Dim Curr As String: Curr = aString
    Dim wLen As Long: wLen = Len(wString)

    Select Case Left1Right2
        Case 0: GoSub writeLeft: GoSub writeRight
        Case 1: GoSub writeLeft
        Case 2: GoSub writeRight
    End Select

    wrapString = Curr
    
    Exit Function

writeLeft:
    If StrComp(Left(Curr, wLen), wString) = 0 Then
        If removeWrap Then Curr = Right(Curr, Len(Curr) - wLen)
    Else
        If Not removeWrap Then Curr = wString & Curr
    End If
    Return

writeRight:
    If StrComp(Right(Curr, wLen), wString) = 0 Then
        If removeWrap Then Curr = Left(Curr, Len(Curr) - wLen)
    Else
        If Not removeWrap Then Curr = Curr & wString
    End If
    Return

End Function

Add wild cards to Filter

2 Answers2

AutoFilter feat. Wild Card Replacements