use VBA to color specific words in a list

Question

SO I have a list of words ( they are 250ish medications in my Settings sheet ) , and I want to use vba to find those specific words in Column D of another sheet and color them magenta. Column D has 105 cells that are full of text.

text I want to search:

list of meds:

what I want it to look like:

below is what iv gathered from other resources but I just cant get it to work! please let me know if you have any suggestions!

also it kinda has to work with mac and windows excel

   Sub ColorWords3()
  Dim Position As Long, Cell As Range, W As Variant, Words As Variant, Txt As String, druglastcol As Variant, drugs As Variant

  druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row

  'Words = Array("TEXT", "WORD", "THEN")
  Words = Application.Transpose(Sheets("Settings").Range("A4:A" & druglastcol).Text)
  For Each Cell In Columns("D").SpecialCells(xlConstants)
    Txt = " " & UCase(Cell.Value) & " "

    For Each W In Words
      Position = InStr(Txt, W)
      Do While Position > 0
        If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & W & "[!A-Z0-9]" Then
          With Cell.Characters(Position - 1, Len(W)).Font
            .Bold = True
            .Color = vbRed
          End With
        End If
        Position = InStr(Position + 1, Txt, W)
      Loop
    Next
  Next
End Sub

Answer 1

Like is case-sensitive, so you need to upper-case your drug names to match your upper-cased blocks of text.

If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & UCase(W) & "[!A-Z0-9]" Then

Using Like gets a bit clunky so here's a RegExp-based approach:

EDIT - added a working Like/InStr version...

Sub ColorWords()

    Dim Cell As Range, W, Words, matches As Collection, m

    With Sheets("Settings")
        Words = Application.Transpose(.Range(.Range("A4"), _
                                      .Cells(.Rows.Count, 1).End(xlUp)))
    End With

    For Each Cell In ActiveSheet.Columns("D").SpecialCells(xlConstants)
        For Each W In Words
            'Set matches = AllMatchesRegEx(Cell.Text, W) 'windows only
            Set matches = AllMatchesInStr(Cell.Text, W)  'windows+mac
            For Each m In matches
                Debug.Print Cell.Address, W, m
                With Cell.Characters(m, Len(W)).Font
                    .Bold = True
                    .Color = vbMagenta
                End With
            Next m
        Next
    Next
End Sub

Function AllMatchesInStr(ByVal textToSearch As String, searchTerm)
    Const OUT As String = "[!A-Z0-9]"
    Dim rv As New Collection, pos As Long, start As Long
    Dim next2 As String, next1 As String
    textToSearch = UCase(" " & textToSearch & "  ")
    start = 1
    pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
    Do While pos > 0
        If Mid(textToSearch, pos - 1, 1) Like OUT Then
            next2 = Mid(textToSearch, pos + Len(searchTerm), 2)
            next1 = Left(next2, 1)
            'Handle possible s at end of search term
            If next1 Like OUT Or (next2 Like "S" & OUT) Then
                rv.Add pos - 1
            End If
        End If
        start = pos + 1
        pos = InStr(start, textToSearch, searchTerm, vbTextCompare)
    Loop
    Set AllMatchesInStr = rv
End Function


Function AllMatchesRegEx(textToSearch As String, searchTerm)
    Dim rv As New Collection, matches, m
    Static reg As Object
    If reg Is Nothing Then
        Set reg = CreateObject("VBScript.RegExp")
        reg.Global = True
        reg.IgnoreCase = True
    End If
    reg.Pattern = "\b" & searchTerm & "s?\b" 'Allow for simple plural form,
                                             'flank with word boundaries
    Set matches = reg.Execute(textToSearch)
    For Each m In matches
        rv.Add m.firstindex + 1 'firstindex is zero-based
    Next m
    Set AllMatchesRegEx = rv
End Function

Answer 2

There is a mistake in your code:

Words = Application.Transpose(Sheets("Settings").Range("A4:A" & Dr).Text)

what is Dr?

Also don't do this:

druglastcol = Sheets("Settings").Range("A4:A" & Rows.Count).End(xlDown).Row

Do this instead:

druglastcol = Sheets("Settings").Range("A" & Rows.Count).End(xlUp).Row

The reason we do it this way is the method you have used will stop if there is a blank row in the data, the method i have posted comes from the bottom up so will always grab the true last row.

Answer 3

Try

Sub test()
    Dim Ws As Worksheet
    Dim s As String
    Dim vDB
    Dim i As Long

    'Application.ScreenUpdating = False
    Set Ws = Sheets("Settings")
    With Ws
        vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
    End With
    For i = 1 To UBound(vDB, 1)
        s = vDB(i, 1)
        setCharacterColor s
    Next i
    'Application.ScreenUpdating = True
End Sub

Sub setCharacterColor(strPattern As String)
    Dim mCol As Object 'MatchCollection
    Dim Ws As Worksheet
    Dim rngDB As Range, rng As Range
    Dim s As String
    Dim i As Integer, Ln As Integer

    Set Ws = Sheets("Facts")
    Set rngDB = Ws.Range("d1", Ws.Range("d" & Rows.Count).End(xlUp))

    For Each rng In rngDB
        s = rng.Value
        Set mCol = GetRegEx(s, strPattern)
        If Not mCol Is Nothing Then
            For i = 0 To mCol.Count - 1
                c = mCol.Item(i).FirstIndex + 1
                Ln = mCol.Item(i).Length
                With rng.Characters(c, Ln).Font
                    .Bold = True
                    .Color = vbMagenta
                End With
            Next i
        End If
    Next
End Sub

Function GetRegEx(StrInput As String, strPattern As String) As Object
    Dim RegEx As Object 'New RegExp
    Set RegEx = CreateObject("VBScript.RegExp") 'New RegExp
    With RegEx
        .Global = True
        .IgnoreCase = False
        .MultiLine = True
        .Pattern = strPattern
    End With
    If RegEx.test(StrInput) Then
        Set GetRegEx = RegEx.Execute(StrInput)
    End If
End Function

If your use Mac then try below.

Sub test()
    Dim Ws As Worksheet, WsColor As Worksheet
    Dim rngDB As Range, rng As Range
    Dim s As String
    Dim vDB, vR
    Dim i As Long, Ln As Integer
    Dim j As Index
    Dim st, et

    Application.ScreenUpdating = False
    st = Timer
    Set Ws = Sheets("Settings")
    Set WsColor = Sheets("Facts")
    With Ws
        vDB = .Range("a1", .Range("a" & Rows.Count).End(xlUp))
    End With
    With WsColor
       Set rngDB = .Range("d1", .Range("d" & Rows.Count).End(xlUp))
    End With

    For Each rng In rngDB
        For i = 1 To UBound(vDB, 1)
            Ln = Len(vDB(i, 1)) 'String Length
            vR = getItem(rng, vDB(i, 1)) 'string startedIndex
            If IsArray(vR) And Not IsEmpty(vR) Then
                For j = 1 To UBound(vR)
                    With rng.Characters(vR(j), Ln).Font
                        .Bold = True
                        .Color = vbMagenta
                    End With
                Next j
            End If
        Next i
    Next rng

    Application.ScreenUpdating = True
    et = Timer
    Debug.Print et - st
End Sub
Function getItem(rng As Range, v As Variant) As Variant
    Dim vR()
    Dim k As Integer, s As Integer, n As Index
    Dim str As String
    str = rng.Text
    s = 1
    Do
        n = InStr(s, str, v)
        If n > 0 Then
            k = k + 1
            ReDim Preserve vR(1 To k)
            vR(k) = n
        End If
        s = n + Len(v)
        DoEvents
    Loop While n > 0
    If k Then
        getItem = vR
    Else
        getItem = Empty
    End If

End Function