VBA macro: If Range Contains Words from Another Range Then Type x in Third Range-CodePudding

I would like to solve the following problem:

In Worksheet1 I have a range in text form from O3 to O4500. If the cells in this range contain certain words, I want an "x" to be put in the range U3:U4500 (in the same row). The words to be tested are in range B4:B15 in another Worksheet (Worksheet2).

I made it work with the following code (solution1), but now I don't want to type the code manually for word1, word2, words3... instead it should be taken from the other range in Worksheet 2 (see my draft below in solution2). I believe the problem are the "* *" which are missing when I use the referral to the other range.

Any help is very much appreciated!

Sub solution1()
    Dim i As Long
        For i = 3 To 4500

            If LCase$(Worksheet1.Range("O" & i).Value) Like "*word1*" Or _
            LCase$(Worksheet1.Range("O" & i).Value) Like "*word2*" Or _
            LCase$(Worksheet1.Range("O" & i).Value) Like "*word3*" Then
            Worksheet1.Range("U" & i).Value = "x"

            End If
        Next
End Sub

Sub solution2()
    Dim i As Long, c As Long

    For i = 3 To 4500
    For c = 4 To 15

        If LCase$(Worksheet1.Range("O" & i).Value) Like LCase$(Worksheet2.Range("B" & c).Value) Then
        Worksheet1.Range("U" & i).Value = "x"

        End If

    Next

    Next

End Sub

CodePudding user response：

try something like:

Sub solution2()
    Dim i As Long, c As Long

    searchstring = LCase$(Worksheets("Worksheet2").Range("B1").Value & "|" & Worksheets("Worksheet2").Range("B2").Value & "|" & Worksheets("Worksheet2").Range("B3").Value)

    For i = 2 To 9
        If Len(LCase$(Worksheets("Worksheet1").Range("O" & i).Value)) < 1 Then GoTo neexxtt
          'line above prevents empty lines to be marked
        If InStr(searchstring, LCase$(Worksheets("Worksheet1").Range("O" & i).Value)) <> 0 Then Worksheets("Worksheet1").Range("U" & i).Value = "x"
    
    neexxtt:
        Next
    
    End Sub

CodePudding user response：

A VBA Lookup: Using an (Array)Formula For Partial Matches

In Excel, in cell U3, you could use the following array formula:
```
=IF(COUNT(MATCH("*"&Sheet2!$B$4:$B$15&"*",O3,0))>0,"X","")
```
and copy it down (adjust the lookup worksheet name (Sheet2)).
The following solution is based on this formula avoiding any loops.

Sub VBALookup()
    
    Const Flag As String = "x"
    
    ' Reference the ranges.
    
    Dim srg As Range ' Source
    Dim drg As Range ' Destination
    Dim lrg As Range ' Lookup
    
    With Worksheet1
        Set srg = .Range("O3", .Cells(.Rows.Count, "O").End(xlUp))
        Set drg = srg.EntireRow.Columns("U")
    End With
    
    With Worksheet2
        Set lrg = .Range("B4", .Cells(.Rows.Count, "B").End(xlUp))
    End With
    
    ' Build the array formula.
    
    Dim ArrayFormula As String
    ArrayFormula = "=IF(COUNT(MATCH(""*""&'" & Worksheet2.Name & "'!" _
        & lrg.Address & "&""*""," & srg.Cells(1).Address(0, 0) & ",0))>0,""" _
        & Flag & ""","""")"
    
    ' Write the formulae (values).
    
    With drg
        ' Write the array formula to the first cell.
        .Cells(1).FormulaArray = ArrayFormula
        ' Autofill to the bottom.
        .Cells(1).AutoFill .Cells, xlFillDefault
        
        ' Not sure, but instead of the previous 2 lines, in Office 365,
        ' the following single line should work:
        '.Cells.Formula = ArrayFormula
        
        ' Convert to values (out-comment if you want to keep the formulae).
        .Value = .Value
    End With

End Sub