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
