Verwenden von Excel VBA zum Ändern der Farbe eines Worts basierend auf dem Wort in einer Zeichenfolge?

Question

Ich möchte, dass die Schriftfarbe die Farbe widerspiegelt, die als ein Wort geschrieben wird. z.B. Jedes Mal, wenn das Wort "rot" in einer Zeichenfolge erscheint, möchte ich, dass die Schriftart des Wortes rot rot (oder rot hervorgehoben) ist. Ich habe Zeichenketten in Zellen mit dem Namen einer Site, einem Deadline- und RAG-Status. Diese befinden sich innerhalb einer Zelle, getrennt durch einen Zeilenumbruch (char (10)). Ich habe Zellenspalten basierend auf dem Stichtag und Zeilen nach Arbeitstyp, so dass ich nicht einfach jedes Textsegment in eine eigene Zelle aufteilen und bedingte Formatierung verwenden kann, ohne dieses Tabellenlayout zu unterbrechen. Die Zeichenfolge wird aus Code erstellt, der Text verkettet und anschließend in der Formel referenziert wird. Ich kann grundlegende VBA schreiben, aber habe keine Ahnung, wie ich das tun konnte, aber den concat-Code (von Chandoo) beigefügt, um zu veranschaulichen, wie die Textzeichenfolge aufgebaut wird.

Kann jemand beraten, wie ich das bitte angehen sollte? Oder schlagen Sie Alternativen zu diesem Ansatz vor.

Answer 1

Zuerst müssen Sie die Startposition des Suchbegriffs innerhalb der Zeichenfolge finden, so

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

dann innerhalb der angegebenen Zelle, verwenden Sie die Zeichen-Eigenschaft und die bekannte Länge die Farbe ändern

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

tun Sie dies für jede gewünschte Farbe und Ihre Zellen werden je nach Bedarf

Answer 2

Dank RGA geändert werden. Ich habe benutzt, was du schreibst, um das Folgende zu schreiben. Nicht das Schönste, aber es erlaubt mir, jeden Zeilenumbruch auf meinem Blatt mit der entsprechenden Farbe zu färben. Ich musste meine Formel in Werte umwandeln, damit sie funktioniert. Nochmals vielen Dank, ich hätte keine Ahnung, wo ich ohne dich anfangen könnte.

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