使用Excel VBA根據字符串中的單詞更改單詞的顏色？

Question

我希望字體顏色能夠反映出寫成單詞的顏色。 例如，每次單詞“red”出現在字符串中時，我希望單詞red的字體為紅色（或以紅色突出顯示）。 我在單元格中有文本字符串，其中包含網站名稱，截止日期和RAG狀態。 它們在一個單元格內，由換行符（char（10））分隔。 我有基於截止日期的單元格列和按工作類型划分的行，因此我無法輕松地將每個文本段拆分為自己的單元格，並使用條件格式而不會破壞此表格布局。 該字符串是根據連接文本的代碼構建的，然后在公式中引用。 我可以編寫基本的VBA，但是我不知道如何做到這一點但是附加了concat代碼（來自Chandoo）來說明如何構建文本字符串。

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

有人可以建議我該如何處理這個問題嗎？ 或建議任何替代方法。

Answer 1

首先，您需要在字符串中找到搜索詞的起始位置，所以

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

然后，在指定的單元格內，使用characters屬性和已知長度來更改顏色

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

對每種所需顏色執行此操作，您的單元格將根據需要進行更改

Answer 2

謝謝RGA。 我用你所寫的內容寫下面的內容。 不是最新的，但它允許我為我的工作表上的每個換行顏色與文本的相應顏色。我必須將我的公式轉換為值才能工作。 再次感謝，我不知道在沒有你的情況下從哪里開始。

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