используйте VBA для указания цвета c слов в списке

Question

ТАК У меня есть список слов (это 250i sh лекарств на моем листе настроек), и я хочу использовать vba, чтобы найти эти указанные c слова в столбце D другого листа и покрасить их в пурпурный цвет. Столбец D содержит 105 ячеек, заполненных текстом.

текст, который я хочу найти:

список лекарств:

как я хочу, чтобы это выглядело:

ниже что я собрал из других ресурсов, но я просто не могу заставить его работать! Пожалуйста, дайте мне знать, если у вас есть предложения!

также он должен работать с ма c и 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 чувствителен к регистру, поэтому вам нужно вводить названия лекарств в верхнем регистре, чтобы они соответствовали вашим блокам текста в верхнем регистре.

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

Использование Like становится немного неуклюжим, поэтому вот RegExp подход на основе:

EDIT - добавлена ​​рабочая версия Like / InStr ...

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

Попробуйте

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

Если вы используете Ма c, попробуйте ниже.

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

Answer 3

В вашем коде есть ошибка:

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

что такое Dr?

Также не делайте этого:

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

Сделайте это вместо этого:

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

Причина, по которой мы делаем это таким образом, заключается в том, что использованный вами метод остановится, если в данных есть пустая строка, а метод, который я разместил, идет снизу вверх, поэтому всегда будет захватывать истинный последний ряд.