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

[beginnermacro]

Hello everyone,

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 (green), 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 red). 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

 

[mumps]

Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim i As Long, srcWS As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant, arr() As Variant, dic As Object, cnt As Long: cnt = 0
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    v1 = desWS.Range("O3:O4500").Value
    v2 = srcWS.Range("B4:B15").Value
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        If Not dic.exists(v1(i, 1)) Then
            dic.Add v1(i, 1), i + 2
        End If
    Next i
    For i = LBound(v2) To UBound(v2)
        If dic.exists(v2(i, 1)) Then
            desWS.Range("U" & dic(v2(i, 1))) = "x"
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[mumps]

Sorry, I just saw that you used "like". Try:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim i As Long, srcWS As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant, arr() As Variant, dic As Object, cnt As Long: cnt = 0
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    v1 = desWS.Range("O3:O4500").Value
    v2 = srcWS.Range("B4:B15").Value
    'Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(v1) To UBound(v1)
        For ii = LBound(v2) To UBound(v2)
            If v1(i, 1) Like "*" & v2(ii, 1) & "*" Then
                desWS.Range("U" & i + 2) = "x"
            End If
        Next ii
    Next i
    Application.ScreenUpdating = True
End Sub

 

[beginnermacro]

Works like a charm! Thanks a lot! I just added LCase$ to v1 in the IF condition.

Could you explain to me what this line is for? Was it a comment on purpose?
'Set dic = CreateObject("Scripting.Dictionary")

 

[mumps]

You are very welcome. My apologies. Here is the revised version:

Sub CompareData()
    Application.ScreenUpdating = False
    Dim i As Long,  ii As Long, srcWS As Worksheet, desWS As Worksheet, v1 As Variant, v2 As Variant
    Set desWS = Sheets("Sheet1")
    Set srcWS = Sheets("Sheet2")
    v1 = desWS.Range("O3:O4500").Value
    v2 = srcWS.Range("B4:B15").Value
    For i = LBound(v1) To UBound(v1)
        For ii = LBound(v2) To UBound(v2)
            If v1(i, 1) Like "*" & v2(ii, 1) & "*" Then
                desWS.Range("U" & i + 2) = "x"
            End If
        Next ii
    Next i
    Application.ScreenUpdating = True
End Sub