Форматирование списка текстовых строк в 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 

Edit:

Клетки мне нужно быть выделены элементы, перечисленные в формате, разделенном запятыми. Например, «Apple 1, Apple 3, Banana 4, Orange». Список значений для поиска находится в разных ячейках «Apple», «Banana 4». Я просто хочу выделить «Banana 4», потому что это соответствие EXACT с значениями, разделенными запятыми. В текущей формулировке текст, который гласит «Apple 1» или «Apple 4», будет частично выделен.

Edit 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), которые вам нужно будет для настройки вашего листа. Это должно (пальцы скрещены) работать!