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

Question

我想让字体颜色反映写成单词的颜色。例如每当单词“红色”出现在字符串中时，我希望红色字体的字体为红色（或用红色突出显示）。我在单元格中有一串文字，其中包含网站的名称，截止日期和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) 

然后，指定单元格内，使用字符属性和已知长度来改变颜色

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