Excel VBAを使用して、文字列内の単語に基づいて単語の色を変更しますか？

Question

単語として書かれた色をフォントの色に反映させたい。例えば文字列に "red"という単語が表示されるたびに、単語redのフォントを赤色（または赤色で強調表示）にします。私は、サイトの名前、期限、RAGの状態で、セルにテキスト文字列を持っています。これらは1つのセル内にあり、改行（char（10））で区切られています。私はデッドラインの日付に基づいてセルの列を持ち、作業の種類ごとに行を並べるので、各テキストセグメントをそれぞれのセルに簡単に分割したり、この表形式のレイアウトを破ることなく条件付き書式を使用することはできません。文字列は、テキストを連結してから式で参照するコードから作成されます。 私は基本的なVBAを書くことができますが、どのように私はこれを行うことができますが、文字列の構築方法を示すために（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