Change font color based on partial string match to Lists

Question

I have a two worksheets with a list of devices in Sheet1 column A with installed apps, column B, and need to color code apps based on certain criteria on Sheet 2. I have three lists with all the possible applications and I am looking for a way to color code the text of the applications, not the entire cell, if the application name matches an application from the three lists.....If the application is in Sheet 2 Column A then change the font color of that app name to Red, if the application is in Sheet 2 Column B, then change the font color to Blue and Green for the 3rd List in column C. I have roughly 750 devices and about 150 applications split between 3 lists that I need to have this done. Here is the code I have so far. It works to some degree. It works with a sample sheet wiht a few apps perfectly, but once I apply it to my main sheet with 150 or so applications it doesn't change the font of all the apps listed.

Option Explicit

Sub Macro1()

    Dim Cell    As Range
    Dim Dict    As Object
    Dim Key     As String
    Dim Matches As Object
    Dim n       As Long
    Dim RegExp  As Object
    Dim Rng     As Object
    Dim Wks     As Worksheet

        Set Dict = CreateObject("Scripting.Dictionary")
            Dict.CompareMode = vbTextCompare

        Set Wks = ThisWorkbook.Worksheets("Sheet2")

        Set Rng = Wks.Range("A1").CurrentRegion
        Set Rng = Intersect(Rng, Rng.Offset(1, 0))

            For Each Cell In Rng.Cells
                Key = Trim(Cell)
                If Key <> "" Then
                    If Not Dict.Exists(Key) Then
                        Dict.Add Key, Cell.Font.Color
                    End If
                End If
            Next Cell

        Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.IgnoreCase = True
            RegExp.Global = True
            RegExp.Pattern = "\w+"

        Set Wks = ThisWorkbook.Worksheets("Sheet1")

        Set Rng = Wks.Range("A1").CurrentRegion
        Set Rng = Intersect(Rng, Rng.Offset(1, 0))

            For Each Cell In Rng.Columns(2).Cells
                Set Matches = RegExp.Execute(Cell.Value)
                For n = 0 To Matches.Count - 1
                    Key = Matches(n)
                    If Dict.Exists(Key) Then
                        Cell.Characters(Matches(n).FirstIndex + 1, Matches(n).Length).Font.Color = Dict(Key)
                    End If
                Next n
            Next Cell

End Sub

I apologize the code is broken up. First time posting code and had trouble getting it formatted properly. — NTel
also you can upload the file to onedrive/google drive and post the link — Ricardo Diaz
I uploaded a couple snippets, but I may take Ricardo's advice and upload to google drive. — NTel

CDP1802 CDP1802 · Accepted Answer · 2020-02-07T16:41:23

Still using a dictionary but build the pattern from the keys. This will also match misspelt words like Excell.

Sub Macro1()

    Dim Cell    As Range
    Dim Dict    As Object
    Dim Key     As String

    Dim n       As Long
    Dim RegExp  As Object
    Dim Rng     As Object
    Dim Wks     As Worksheet

    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = vbTextCompare

    Set Wks = ThisWorkbook.Worksheets("Sheet2")

    Set Rng = Wks.UsedRange
    Set Rng = Intersect(Rng, Rng.Offset(1, 0))

    For Each Cell In Rng.Cells
        Key = Trim(Cell)
        If Key <> "" Then
            If Not Dict.Exists(Key) Then
                Dict.Add Key, Cell.Font.color
            End If
        End If
    Next Cell

    Dim Pattern As String
    Pattern = Join(Dict.keys, "|")

    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.IgnoreCase = True
    RegExp.Global = True
    RegExp.Pattern = "(" & Pattern & ")"

    Set Wks = ThisWorkbook.Worksheets("Sheet1")

    Set Rng = Wks.Range("A1").CurrentRegion
    Set Rng = Intersect(Rng, Rng.Offset(1, 0))

    Dim Matches As Object, Match As Object, sApp As String, count As Integer
    Dim startC As Integer, endC As Integer
    For Each Cell In Rng.Columns(2).Cells
       If RegExp.test(Cell.Value) Then
         Set Matches = RegExp.Execute(Cell.Value)
         For n = 0 To Matches.count - 1
           sApp = CStr(Matches(n))
           startC = Matches(n).FirstIndex + 1
           Cell.Characters(startC, Matches(n).Length).Font.color = Dict(sApp)
           count = count + 1
           'Debug.Print Cell, sApp, startC
         Next
       End If
    Next
    MsgBox "Ended Matches = " & count, vbInformation
End Sub

Change font color based on partial string match to Lists

1 Answers