Question

我试图将字体变为红色，以便在excel中出现单词列表。到目前为止，我能够找到一个单词，但我需要搜索整个数组。我是VBA的新手并且苦苦挣扎。到目前为止，我已经能够找到这个解决方案，但它涉及找到一个字符串，＆＃34; F1＆＃34;：

Sub test4String2color()
Dim strTest As String
Dim strLen As Integer
strTest = Range("F1")
For Each cell In Range("A1:D100")
If InStr(cell, strTest) > 0 Then
cell.Characters(InStr(cell, strTest), strLen).Font.Color = vbRed
End If
Next
End Sub

编辑：

我需要突出显示的单元格以逗号分隔格式列出项目。例如，＆＃34; Apple 1，Apple 3，Banana 4，Orange＆＃34;。要搜索的值列表位于不同的单元格中，＆＃34; Apple＆＃34;，＆＃34; Banana 4＆＃34;。我只想强调一下香蕉4＆＃34;因为这与逗号分隔值完全匹配。在目前的表述中，文字说明了＆＃34; Apple 1＆＃34;或＆＃34; Apple 4＆＃34;将部分突出显示。

编辑2：

这是我工作簿中的实际格式：

Answer 1

这是一种通过循环遍历范围，集合和数组来实现所需目标的方法。

代码将在集合（您选择的匹配单词）和数组（每个单元格中分隔的单词串）之间找到匹配项。如果找到匹配项，则设置字符串中的起始和结束字符，并将这些值之间的字符着色。

Sub ColorMatchingString()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
    Dim strTest As Collection: Set strTest = New Collection
    Dim udRange As Range: Set udRange = ws.Range("AC2:AC311") 'Define Search Ranges
    Dim myCell, myMatch, myString, i
    Dim temp() As String, tempLength As Integer, stringLength As Integer
    Dim startLength as Integer

    For Each myMatch In udRange 'Build the collection with Search Range Values
        strTest.Add myMatch.Value
    Next myMatch

    For Each myCell In ws.Range("A2:AB1125") 'Loop through each cell in range
        temp() = Split(myCell.Text, ", ") 'define our temp array as "," delimited
        startLength = 0
        stringLength = 0

        For i = 0 To UBound(temp) 'Loop through each item in temp array
            tempLength = Len(temp(i))
            stringLength = stringLength + tempLength + 2

            For Each myString In strTest
  'Below compares the temp array value to the collection value. If matched, color red.
                If StrComp(temp(i), myString, vbTextCompare) = 0 Then 
                    startLength = stringLength - tempLength - 1
                    myCell.Characters(startLength, tempLength).Font.Color = vbRed
                End If
            Next myString
        Next i
        Erase temp 'Always clear your array when it's defined in a loop
    Next myCell
End Sub

Answer 2

为了与原始代码保持一致，您只需添加另一个For each cell in Range（以及其他一些内容）：

Sub test4String2color()
Dim wb As Workbook
Dim ws As Worksheet

Dim strLen  As Integer
Dim i       As Long
Dim tst As Range

Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet

Dim keyWordRng As Range
Dim dataRng As Range
Set keyWordRng = ws.Range("F1:F2")
Set dataRng = ws.Range("A1:A5")

For Each tst In keyWordRng
    Debug.Print "Searching for: " & tst
    For Each cell In dataRng
        If tst.Value = cell.Value Then
            cell.Characters(InStr(cell, tst), strLen).Font.Color = vbRed
        ElseIf InStr(1, cell.Value, ",") > 0 Then
            getWordsInCell cell, tst.Value
        End If
    Next cell
Next tst
End Sub


Sub getWordsInCell(ByVal cel As Range, keyword As String)
Dim words() As String
Dim keywordS As Integer, keywordE As Integer
words = Split(cel.Value, ",")

Dim i As Long
For i = LBound(words) To UBound(words)
    Debug.Print "Found multiple words - one of them is: " & words(i)
    If Trim(words(i)) = keyword Then
        keywordS = ActiveWorkbook.WorksheetFunction.Search(keyword, cel, 1)
        keywordE = ActiveWorkbook.WorksheetFunction.Search(",", cel, keywordS)
        cel.Characters(keywordS, (keywordE - keywordS)).Font.Color = vbRed
    End If
Next i

End Sub

请注意我已添加到您需要调整工作表的范围（keyWordRng和dataRng）。这应该（手指交叉）工作！

格式化Excel中的文本字符串列表

2 个答案: