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

Question

我想將字體變爲紅色，以便在Excel中出現單詞列表。到目前爲止，我能夠找到一個單詞，但我需要搜索整個數組。我是VBA的新手，並且很掙扎。到目前爲止，我已經能夠發現這是一個解決方案，但它找到一個字符串，「F1」交易：

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 

編輯：

我需要強調已在項目中列出的細胞用逗號分隔格式。例如，「Apple 1，Apple 3，Banana 4，Orange」。要搜索的值列表位於不同的單元格中，「Apple」，「Banana 4」。我只想突出顯示「Banana 4」，因爲這是與逗號分隔值完全匹配的。在目前的表述中，說「Apple 1」或「Apple 4」的文字會部分突出顯示。

編輯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），你將需要調整您的工作表。這應該（手指交叉）工作！