Excel VBA to Search for an Array of Strings within a String

Question

I am trying to create a looping variable that looks through a string for an array of strings and assigns them to a group if a match is found, however, I don't need it to be an exact match, just if the source string is LIKE the search string. Example code posted below:

Sub add_Categories()

Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False



Set rRange = Range("B1", Range("B65536").End(xlUp))

Application.DisplayAlerts = False

With wSheetStart
    For Each rCell In rRange


    If rCell Like "*Apple*" Then rCell.Offset(0, 2) = "Grocery"
    If rCell Like "*Orange*" Then rCell.Offset(0, 2) = "Grocery
    If rCell Like "*Mop*" Then rCell.Offset(0, 2) = "Kitchen"
    If rCell Like "*Broom*" Then rCell.Offset(0, 2) = "Kitchen"
    'If rCell Like "*Shirt*" Then rCell.Offset(0, 2) = "Clothing"
    'If rCell Like "*Pants*" Then rCell.Offset(0, 2) = "Clothing"


    Next rCell
End With

With wSheetStart
    '.AutoFilterMode = False
    .Activate
End With

On Error GoTo 0

Application.DisplayAlerts = True

End Sub

The example above only has two strings per category, but in reality I have hundreds and it would be much easier to enter them as an array than to have a line for each statement. Any help is much appreciated.

Answer 1

This is one way you can use an array and loop through it:

Sub add_Categories()
Dim rRange As Range, rCell As Range, wSheet As Worksheet, wSheetStart As Worksheet, X As Long, FindArr As Variant, FoundArr As Variant
FindArr = Array("Apple", "Orange", "Mop", "Broom", "Shirt", "Pants")
FoundArr = Array("Grocery", "Grocery", "Kitchen", "Kitchen", "Clothing", "Clothing")
Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
Set rRange = Range("B1", Range("B" & Rows.Count).End(xlUp))
Application.DisplayAlerts = False
With wSheetStart
    For Each rCell In rRange
        For X = LBound(FindArr) To UBound(FindArr)
            If rCell Like "*" & FindArr(X) & "*" Then rCell.Offset(0, 2) = FoundArr(X)
        Next
    Next
End With
With wSheetStart
    '.AutoFilterMode = False
    .Activate
End With
On Error GoTo 0
Application.DisplayAlerts = True
End Sub

Add what you need to FindArr and the corosponding output to FoundArr

Also note the change here: Set rRange = Range("B1", Range("B" & Rows.Count).End(xlUp)) use rows.count instead of hard coding a row number.