使用Excel VBA根据字符串中的单词更改单词的颜色？

Question

I want the font colour to reflect the colour written as a word. eg Every time the word "red" appears in a string I want the font of the word red to be red (or highlighted in red). I have strings of text in cells with the name of a site, a deadline and RAG status. These are within one cell, separated by a line break (char(10)). I have columns of cells based on deadline date, and rows by work type so I can't easily split each text segment into its own cell and use conditional formatting without breaking this tabular layout. The string is built from code which concatenates text, and then referenced in formula. I can write basic VBA but haven't a clue how i could do this but have attached the concat code (from Chandoo) to illustrate how the text string is built up.

Function concat(useThis As Range, Optional delim As String) As String
' this function will concatenate a range of cells and return one string
' useful when you have a rather large range of cells that you need to add up
For Each cell In useThis
If CStr(cell.Value) <> "" And CStr(cell.Value) <> " " Then
retVal = retVal & CStr(cell.Value) & dlm
End If
Next
If dlm <> "" Then
retVal = Left(retVal, Len(retVal) - Len(dlm))
End If
concat = retVal
End Function

Can anybody advise how I should approach this please? Or suggest any alternatives to this approach.

Answer 1

First, you need to find the start location of the search term within the string, so

startRed = InStr(0,searchstring,"Red",CompareMethod.Text)

then, within the specified cell, use the characters property and the known length to change the color

With Cell.Characters(Start:= startRed, Length:= Len("Red")).Font
     .Color = RGB(255,0,0)

Do this for each desired color and your cells will be changed as needed

Answer 2

Thanks RGA. I used what you put to write the below. Not the neatest but it allows me to colour each linebreak on my sheet with the corresponding colour to the text.I had to convert my formula to values for it to work. Thanks again, I wouldn't have had a clue where to start without you.

Sub ColourText2()

TurnOff
Dim startRed As Integer, startChar As Integer, startAmber As Integer, startGreen As Integer, x As Integer, i As Integer, startLB As Integer, endLB As     Integer, iCount As Integer
Dim searchString As String, searchChar As String
Dim clr As Long
Dim cell As Range


For x = 6 To 22
iCount = Worksheets("MySheet").Range("D" & x & ":S" & x).Count

Range("C" & x).Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("C" & x & ":S" & x), Type:=xlFillDefault
Range("C" & x & ":S" & x).Select
Worksheets("MySheet").Calculate
 Range("D" & x & ":S" & x).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

For Each cell In Worksheets("MySheet").Range("D" & x & ":S" & x)
searchString = cell


Application.StatusBar = i & "of: " & iCount
startChar = 1
    For startLB = 1 To Len(cell)

cell.Select
        If startChar = 1 Then
            startLB = 1
            endLB = 1
        Else
            startLB = InStr(endLB, searchString, Chr(10), vbTextCompare)
        End If

       startGreen = InStr(endLB, searchString, "green", vbTextCompare)
            'MsgBox startGreen
       startAmber = InStr(endLB, searchString, "amber", vbTextCompare)
          'MsgBox startAmber
       startRed = InStr(endLB, searchString, "red", vbTextCompare)
           'MsgBox startRed
       endLB = InStr(endLB + 1, searchString, Chr(10), vbTextCompare)

        If startGreen < endLB And startGreen <> 0 Then
             startChar = startGreen
             cell.Characters(startLB, endLB - startLB).Font.Color = RGB(0, 153, 0)
        ElseIf startAmber < endLB And startAmber <> 0 Then
            startChar = startAmber
            cell.Characters(startLB, endLB - startLB).Font.Color = RGB(226, 107, 10)
            cell.Characters(startLB, endLB - startLB).Font.Underline = xlUnderlineStyleSingle
        ElseIf startRed < endLB And startRed <> 0 Then
             startChar = startRed
             cell.Characters(startLB, endLB - startLB).Font.Color = RGB(255, 0, 0)
             cell.Characters(startLB, endLB - startLB).Font.Underline = xlUnderlineStyleSingle
             Else
             GoTo MoveOn
        End If

        If startChar = 0 Then GoTo MoveOn      




MoveOn:
Next



Next cell
x = x + 1
Next

TurnON
Application.StatusBar = False

MsgBox "finished"
End Sub