Excel 使用VBA为列表中的特定单词着色_Excel_Vba

Excel 使用VBA为列表中的特定单词着色

excel vba

Excel 使用VBA为列表中的特定单词着色,excel,vba,Excel,Vba,所以我有一个单词列表（它们在我的设置表中），我想使用vba在另一张表的D列中找到这些特定的单词，并将它们涂成洋红色。D列有105个充满文本的单元格我要搜索的文本：药物清单：我希望它看起来像什么：下面是iv从其他资源收集的内容，但我就是无法让它工作！如果你有任何建议，请告诉我它还需要与mac和windows excel配合使用 Sub ColorWords3() Dim Position As Long, Cell As Range, W As Variant, Word

所以我有一个单词列表（它们在我的设置表中），我想使用vba在另一张表的D列中找到这些特定的单词，并将它们涂成洋红色。D列有105个充满文本的单元格

我要搜索的文本：

药物清单：

我希望它看起来像什么：

下面是iv从其他资源收集的内容，但我就是无法让它工作！如果你有任何建议，请告诉我

它还需要与mac和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

您的代码中有一个错误：

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

我们这样做的原因是，如果数据中有空行，您使用的方法将停止，我发布的方法是自下而上的，因此将始终抓住真正的最后一行。

您的代码中有一个错误：

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

我们这样做的原因是，如果数据中有空行，您使用的方法将停止，我发布的方法是自下而上的，因此将始终抓住真正的最后一行。

Like区分大小写，因此您需要将药物名称大写以匹配大写文本块

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

像一样使用

会有点笨拙，因此这里有一种基于RegExp的方法：
编辑-添加了类似于/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

Like是区分大小写的，所以您需要将药物名称大写以匹配大写的文本块
If Mid(Txt, Position - 1, Len(W) + 2) Like "[!A-Z0-9]" & UCase(W) & "[!A-Z0-9]" Then

像

一样使用

会有点笨拙，因此这里有一种基于RegExp的方法：
编辑-添加了类似于/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

试一试
如果您使用Mac，请尝试下面的方法
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

试一试
如果您使用Mac，请尝试下面的方法
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

很抱歉我把Dr改为druglastcol，这样变量名就更具描述性了！但是更改它仍然没有帮助。当我将xlDown更改为xlUp而不是返回值258时，它返回3did。在将其更改为xlUp之前，您从范围中删除了4:A
？否？我的药物清单是A4到A258，但我想确定如果我以后在清单底部添加一种药物，它会识别添加到清单中的iv。你有没有想过为什么不需要着色？复制并粘贴我的建议，对于xlup，你的代码是：druglastcol=Sheets（“Settings”）.Range（“A4:A”和Rows.Count”）.End（xlDown）。Row
给你3，我的代码是：druglastcol=Sheets（“Settings”）.Range（“A”和Rows.Count）。End（xlup）.Row
将为您提供最后一行数据。我仍在处理你的代码，试图回答你的问题。对不起！我把Dr改为druglastcol，这样变量名就更具描述性了！但是更改它仍然没有帮助。当我将xlDown更改为xlUp而不是返回值258时，它返回3did。在将其更改为xlUp之前，您从范围中删除了4:A
？否？我的药物清单是A4到A258，但我想确定如果我以后在清单底部添加一种药物，它会识别添加到清单中的iv。你有没有想过为什么不需要着色？复制并粘贴我的建议，对于xlup，你的代码是：druglastcol=Sheets（“Settings”）.Range（“A4:A”和Rows.Count”）.End（xlDown）。Row
给你3，我的代码是：druglastcol=Sheets（“Settings”）.Range（“A”和Rows.Count）。End（xlup）.Row
将为您提供最后一行数据。我仍在处理你的代码，试图回答你的问题。一些实际的示例数据在这里会很有用。“我不能让它工作”只是不够具体。清楚什么不起作用。显示具有预期输出的示例数据。旁注：druglastcol
是一个非常奇怪的变量行计数名称。您将文本块置于大写，但不是药物名称-“a”类似于“a”
为假。嘿！我加了一些图片！我想把床单放在这里，但我真的不知道怎么做。。tbh这是iv第一次遇到这么多麻烦，不得不发布一些东西。您的图片似乎表明您希望对包含您的一个术语的复数单词进行局部着色，但您的相似模式不允许这样做……一些实际的示例数据在这里会有所帮助。“我不能让它工作”只是不够具体。清楚什么不起作用。显示具有预期输出的示例数据。旁注：druglastcol
是一个非常奇怪的变量行计数名称。您将文本块置于大写，但不是药物名称-“a”类似于“a”
为假。嘿！我加了一些图片！我想把床单放在这里，但我真的不知道怎么做。。tbh这是iv第一次遇到这么多麻烦，并且不得不发布一些东西。您的图片似乎表明您希望对包含您的一个术语的复数单词进行局部着色，但您的相似模式不允许这样做…因此，在我的列表中，它是阿米洛利，我需要它作为阿米洛利，阿米洛利或阿米洛利吗？这就是你的意思吗？就是这样，非常感谢。我要把这个拿出来，然后把它扩展出来，再列出4个不同的东西和4种颜色！我真的很感谢亚尔的帮助！好吧，那么。。。我得到这个错误“ActiveX组件无法创建对象”，但它只在我的mac上。我该如何解决这个问题？Set reg=CreateObject（“VBScript.RegExp”）这是在Mac上不起作用的it Flagsorry行-我应该提到这一点。你仍然可以回到你以前的方法……好吧，我还没有让那个方法起作用：/我不知道为什么它不起作用，所以，在我的列表中，它是阿米洛利，我需要它作为阿米洛利，阿米洛利还是阿米洛利？这就是你的意思吗？就是这样，非常感谢。我要把这个拿出来，然后把它扩展出来，再列出4个不同的东西和4种颜色！我真的很感激