Изменить цвет шрифта на основе частичного совпадения строк со списками

Question

У меня есть две таблицы со списком устройств в столбце A листа 1 с установленными приложениями, столбец B, и мне нужно раскрасить приложения кода в соответствии с определенными критериями на листе 2. У меня есть три списка со всеми возможными приложениями, и я Ищите способ цветной кодировки текста приложений, а не всей ячейки, если имя приложения совпадает с приложением из трех списков ..... Если приложение находится в столбце А листа 2, измените цвет шрифта этого имя приложения - красный, если приложение находится в столбце B листа 2, измените цвет шрифта на синий и зеленый для 3-го списка в столбце C. У меня примерно 750 устройств и около 150 приложений, разделенных между 3 списками, которые мне нужны для этого. Вот код, который у меня есть. Это работает в некоторой степени. Он отлично работает с образцом листа с несколькими приложениями, но как только я применяю его на свой основной лист с 150 или около того приложениями, он не меняет шрифт всех перечисленных приложений.

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

Answer 1

Все еще использую словарь, но строю шаблон из ключей. Это также будет соответствовать ошибочным словам, таким как 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