VBA wildcards or partial matches

Question

My code below looks through a list of keywords in column 37, in rows 5 to 17, in a different sheet called "Weights".

For columns that do not contain these keywords, delete them.

My problem is that it is looking for exact matches, so I need to place some wildcards or adjust the below to include partial matches.

For example, if a keyword is "Open", then the column containing "Open & closed" would be deleted, which is not what I want.

How is best to go about this?

Sub DeleteUneededColumn()

Dim rng As Range, rngcol As Range
Dim findstring As Variant

With Sheets("Weights")
    findstring = .Range(.Cells(5, 37), .Cells(17, 37))
End With
For Each rngcol In Range("A:CZ").Columns
    myVal = 0
    For i = LBound(findstring) To UBound(findstring)
        myVal = myVal + Evaluate("=IF(COUNTIF(" & rngcol.Address & ",""" & findstring(i, 1) & """)>0,1,0)")
    Next
    If myVal = 0 Then
        If Not rng Is Nothing Then
            Set rng = Union(rng, rngcol)
        Else
            Set rng = rngcol
        End If
    End If
Next
If Not rng Is Nothing Then rng.Delete

End Sub

Answer 1

The following code should work for you...

The sub takes the keywords in the Sheet("Weights") and adds them to an array, then loops through the array looking for each term in the destination range. It will them loop through the destination range and remove any columns that don't intersect with the union of all the found search ranges

Set the wsDest and SearchRange to the sheet/range that you want to delete the columns from

Sub RemoveExtraCols()
    Dim wsSrc As Worksheet: Set wsSrc = ThisWorkbook.Worksheets("Weights")
    Dim wsDest As Worksheet: Set wsDest = ActiveSheet

    Dim KeyWords() As String
    Dim Temp As Range, FoundRange As Range, i As Long

    With wsSrc
        ' SrcRange should be a single contiguous row or column
        Dim SrcRange As Range: Set SrcRange = .Range(.Cells(5, 37), .Cells(17, 37))
    End With

    With wsDest
        Dim SearchRange As Range: Set SearchRange = wsDest.UsedRange
    End With

    KeyWords = Split(Join(Application.Transpose(SrcRange), "#"), "#")

    For i = 0 To UBound(KeyWords)
        If KeyWords(i) <> "" Then
            Set Temp = FindAll(KeyWords(i), SearchRange, LookIn:=xlValues, LookAt:=xlPart)
            If FoundRange Is Nothing Then
                Set FoundRange = Temp
            Else
                If Not Temp Is Nothing Then Set FoundRange = Application.Union(FoundRange, Temp)
            End If
        End If
    Next i

    For i = SearchRange.Columns.Count To 1 Step -1
        Set Temp = Application.Intersect(SearchRange.Columns(i), FoundRange)
        If Temp Is Nothing Then
            SearchRange.Columns(i).EntireColumn.Delete
        End If
    Next i
End Sub

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function