Is there a better way to compare against many strings with like?

Viewed 81

I have a long list of words I need to compare against.
As an example fruit and vegetables that needs to be stored cold vs warmer:

Cold
  strawberries
  raspberries
  lettuce


Warm(er)
  cucumber 
  bell pepper 
  tomatoes 

I have a sheet with products and need to loop it:

 For Each cel In rng
    If LCase(cel.Value) Like "*strawberries*" Or LCase(cel.Value) Like "*raspberries*" Or LCase(cel.Value) Like "*lettuce*" Then
        msgbox "Cold"
    ElseIf LCase(cel.Value) Like "*cucumber*" or LCase(cel.Value) Like "*bell pepper*" or LCase(cel.Value) Like "*tomato*" Then
        msgbox "Warmer" 
    End If
Next cel

Is there any way I could this better? The syntax to test against all products will be very very long.
Could I somehow group/list them and make the syntax easier to maintain?

Example of the workbook:
enter image description here

4 Answers

To demonstrate what I meant with a wildcard match:

Sub Test()

Dim rng As Range, cl As Range
Dim Cold As Variant, Warm As Variant

Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A4")
Cold = Array("*strawberries*", "*raspberries*", "*lettuce*")
Warm = Array("*cucumber*", "*bell pepper*", "*tomatoes*")

With Application
    For Each cl In rng
        If .IsNumber(.Match(True, .IsNumber(.Match(Cold, cl, 0)), 0)) Then
        'Or: If UBound(Filter(.IsNumber(.Match(Warm, cl, 0)), True)) = 0 Then
            MsgBox "Cold"
        ElseIf .IsNumber(.Match(True, .IsNumber(.Match(Warm, cl, 0)), 0)) Then
            MsgBox "Warm"
        End If
    Next
End With

End Sub

Alternatively, you could use regular expressions with word-boundaries:

Sub Test()

Dim rng As Range, cl As Range
Dim Cold As String, Warm As String

Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A4")
Cold = "strawberries|raspberries|lettuce"
Warm = "cucumber|bell pepper|tomatoes"

With CreateObject("vbscript.regexp")
    .IgnoreCase = True
    For Each cl In rng
        .Pattern = "\b" & Cold & "\b"
        If .Test(cl) Then
            MsgBox "Cold"
        Else
            .Pattern = "\b" & Warm & "\b"
            If .Test(cl) Then MsgBox "Warm"
        End If
    Next
End With

End Sub

You can also, match both in any case and see if it's supposed to be a combination of warm and cold.

Here is a perfunctory system that would return the information you want from a list of produce.

Sub GetStorageInstruction()
    ' 187
    
    Dim Veggie      As Variant
    Dim Storage     As String
    Dim Txt         As String
    
    Veggie = InputBox("Enter name of fruit or vegetable to store:", _
                      "Get storage instruction")
    Veggie = Trim(Veggie)
    If Len(Veggie) Then
        Storage = StorageInstruction(Veggie)
        If Len(Storage) Then
            Txt = "Store " & Veggie & " at a " & Storage & " location."
        Else
            Txt = "Sorry, I couldn't find instructions on" & vbCr & _
                  "storage of """ & Veggie & """."
        End If
        MsgBox Txt, vbInformation, "Storage instructions"
    End If
End Sub

Private Function StorageInstruction(ByVal Veggie As String) As String
    ' 187
    ' return vbNullString if not found
    
    
    Dim ListRng     As Range
    Dim Fnd         As Range            ' found match
    Dim C           As Long             ' column
    
    ' here items for "Cold" storage are in column A,
    '      items for "Cool" storage are in column B
    Set ListRng = Range("A:B")          ' adjust to suit
    Set Fnd = ListRng.Find(Veggie, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
    If Not Fnd Is Nothing Then
        ' the return result is taken from the caption row (row 1)
        ' of the column in which a match was found
        StorageInstruction = Cells(1, Fnd.Column).Value
    End If
End Function

"Ordinarily", you wouldn't work with an InputBox because it's too error prone (typos) but with a validation list or combo box that is based on the same lists. But for the moment, if you are concerned about not finding "Bell peppers" (plural), consider either listing "Bell pepper" as well or modify the search to LookAt:=xlPart.

To make the above code work for you immediately, just type "Cold" in A1, "Cool" in B1 and a list of produce under each header. The code will return the header from the column where the item was found.

I see that you have now added a view of your worksheet. That is a much better base. Instead of the produce name, list a number from your columns C or D (whichever is unique), in my columns A and B, and enter that number in the InputBox. Once you implement that system you can modify the returned answer by using the number to VLOOKUP the product name so that the description appears in the answer along with the number you entered.

As an afterthought, the best way for you would probably be to just select the row you are interested in, click a button (or keyboard shortcut) and have the storage instruction pop up. But the presumption here is that you should be able to attach VBA code to your workbook.

No. Correct. I solved that with search for asparagus then search again in the same string for potatoes. But I know there will be false matches. There is no way around it. Let's just say, if there is a handful of false matches is better than looking through the full sheet manually (30-40 000 rows). – Andreas 1 hour ago

Here is an example of what I recommend. Feel free to go with other answers. If there are multiple matches then fill the cell with "Cold/Warm" as mentioend in the code comments below. This way you can simply filter on these and fix them manually.

Basic Preparation to test this

  1. Create a master sheet in the file which has the code. Let's call it MasterList. The reason why we are doing this is so that it is easier to maintain and when you are distributing the code file, the masterlist is easily available. You can do version control on the file so that everyone uses the current version. Let's say the MasterList looks like this.

    enter image description here

  2. Let's say the file (as shown in your image) is called MyData.xlsx and the data is in Sheet1. Feel free to change it in the code below. It looks like this

    enter image description here

Code

Option Explicit

Sub Sample()
    Dim wsThis As Worksheet
    
    '~~> This is the hidden sheet which has your master list in the file
    '~~> which has the code
    Set wsThis = ThisWorkbook.Sheets("MasterList")
    
    Dim lRow As Long
    Dim MasterList As Variant
    
    With wsThis
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row
        
        MasterList = .Range("A2:B" & lRow).Value2
    End With
    
    Dim wb As Workbook
    Dim wsThat As Worksheet
    
    '~~> Change this to the workbook where the data needs to be checked
    Set wb = Workbooks.Open("C:\Users\Siddharth Rout\Desktop\MyData.xlsx")
    '~~> Change this to the workseet where the data needs to be checked
    Set wsThat = wb.Sheets("Sheet1")
    
    Dim rngToProcess As Range
    
    With wsThat
        '~~> Find last row in Col E which has names
        lRow = .Range("E" & .Rows.Count).End(xlUp).Row
        
        '~~> Identify your range
        Set rngToProcess = .Range("E2:E" & lRow)
        
        '~~> Insert a blank column for output
        .Columns(6).Insert Shift:=xlToRight
    End With
    
    Dim SearchText As String
    Dim aCell As Range, bCell As Range
    Dim i As Long
    
    '~~> Loop through the masterlist
    For i = LBound(MasterList) To UBound(MasterList)
        SearchText = MasterList(i, 1)
            
        Set aCell = rngToProcess.Find(What:=SearchText, LookIn:=xlValues, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
        
        If Not aCell Is Nothing Then
            Set bCell = aCell
            
            '~~> Get the Warm - Cold - Warm/Cold Status
            aCell.Offset(, 1).Value = GetStatus(MasterList(i, 2), aCell.Offset(, 1).Value)
            
            '~~> Search again for multiple occurences
            Do
               Set aCell = rngToProcess.FindNext(After:=aCell)
        
               If Not aCell Is Nothing Then
                   If aCell.Address = bCell.Address Then Exit Do
                   aCell.Offset(, 1).Value = GetStatus(MasterList(i, 2), aCell.Offset(, 1).Value)
               Else
                   Exit Do
               End If
            Loop
        End If
    Next i
End Sub

'~~> Common function to asign the values
'~~> If there are multiple matches then fill the cell with "Warm/Cold". 
'~~> This way you can simply filter on these and fix them manually.
Private Function GetStatus(MasterStatus As Variant, CurrentStatus As String) As String
    Dim newStatus As String
    
    If MasterStatus = "Cold" Then
        Select Case CurrentStatus
            Case "Warm": newStatus = "Warm/Cold"
            Case Else: newStatus = MasterStatus
        End Select
    ElseIf MasterStatus = "Warm" Then
        Select Case CurrentStatus
            Case "Cold": newStatus = "Warm/Cold"
            Case Else: newStatus = MasterStatus
        End Select
    End If
    
    GetStatus = newStatus
End Function

Output

When you run the above code you get the below output

enter image description here

Here is an alternative to my earlier answer. Install the code below in a standard code module and make some arrangement to call it, perhaps with a keyboard shortcut or even a button on the sheet. Then simply select an item (anywhere in the list, no particular column) and run the code. You don't need to enter anything.

Sub Storage_Instruction()
    ' 187
    
    Const SKUClm    As String = "D"         ' change to point at the SKU column in 'Data'
    Const DescClm   As String = "E"         ' change to point at the Description column in 'Data'
    Const StgClm    As String = "C"         ' change to point at Storage Instruction column in WsList
    
    Dim WsData      As Worksheet
    Dim WsList      As Worksheet
    Dim SKU         As String               ' SKU number from row R
    Dim Desc        As String               ' Description from row R
    Dim R           As Long                 ' the selected row
    Dim LookUpRng   As Range                ' in WsList
    Dim Fnd         As Range                ' found match
    Dim Storage     As Variant
    Dim Txt         As String
    
    Set WsData = Worksheets("Data")         ' insert your data sheet's name here
    Set WsList = Worksheets("Storage")      ' change name to suit
    
    With WsList
        ' my list has an extra column for 'Description'
        ' the storage instruction is in column C (=StgClm)
        Set LookUpRng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, StgClm).End(xlUp))
    End With
    
    If ActiveSheet Is WsData Then
        R = Selection.Row
        With WsData
            SKU = .Cells(R, SKUClm).Value
            Desc = .Cells(R, DescClm).Value
        End With
        Set Fnd = LookUpRng.Find(SKU, LookIn:=xlValues, Lookat:=xlWhole)
        If Fnd Is Nothing Then
            Txt = "Sorry, I couldn't find instructions for the" & vbCr & _
                  "storage of " & Desc & "(SKU " & SKU & ")."
        Else
            Storage = WsList.Cells(Fnd.Row, StgClm).Value
            Txt = "Store " & Desc & " (SKU " & SKU & ") at " & String(2, vbCr) & _
                  String(8, Chr(32)) & UCase(Storage) & String(2, vbCr) & "temperature."
        End If
    End If
    MsgBox Txt, vbInformation, "Storage instruction"
End Sub

For the setup you do need to specify the 3 constants at the top of the procedure and the names of the two worksheets that are referenced.

The list is a simple copy of the SKU column from your big list. In my test I also copied the the descriptions. You may find that way easier to fill the 3rd column, which holds the words "Cool" and "Cold" (or whatever else you want) against each item. The middle column isn't used and not required y the above code.

According to your description, the 'List' sheet should be Very Hidden. In the VB Editor's Project Browser, click on the sheet, bring up its properties and set the Visible property to xlVeryHidden. The sheet can be made visible only by changing this property back to xlVisible. The property setting is saved when you save the workbook.

Related