VBA - 変更されたテキストの色を変更します。

Question

セルのテキストの色が変更された場合は、このコードを変更します。しかし、私はセル内の変更されたテキストの色だけを変更するものを探していました。たとえば、私は、セルA1 =「このセル」を持っていると私は、「このセルは - これは新しいテキストである」に変更したときに、私はただの色を変更したい -

Option Explicit 

Private Sub Worksheet_Change(ByVal Target As Range) 

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then 
     If Target.Font.ColorIndex = 3 Then 
      Target.Font.ColorIndex = 5 
     Else 
      Target.Font.ColorIndex = 3 
     End If 
    End If 

End Sub 

「これが新しいテキストがあります」ありがとう

Answer 1

Gary's Studentのヒントを使用して、私はcellの古い値を保持し、新しい値と比較します。長さを使用して「差」を取得し、「文字」に色付けします。ここに修正があります：

Option Explicit 
Public oldValue As Variant 

Public Sub Worksheet_SelectionChange(ByVal Target As Range) 

    oldValue = Target.Value 

End Sub 

Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim oldColor 

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then 
     If Target.Value <> oldValue Then 
      oldColor = Target.Font.ColorIndex 
      Target.Characters(Len(oldValue) + 1, Len(Target) - Len(oldValue)).Font.ColorIndex = IIf(oldColor = 3, 5, 3) 
     End If 
    End If 

End Sub 

P.S.申し訳ありませんが私の英語

Answer 2

これはフォントを変更しますが、完全ではありません。同じセルに異なるフォントの色がある場合、Target.Font.ColorIndexはNULLを返します。最初の変更でのみ機能します。

Option Explicit 

Dim sOldValue As String 

Private Sub Worksheet_Change(ByVal Target As Range) 

    Dim sNewValue As String 
    Dim sDifference As String 
    Dim lStart As Long 
    Dim lLength As Long 
    Dim lColorIndex As Long 

    On Error GoTo ERROR_HANDLER 

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then 
     sNewValue = Target.Value 
     sDifference = Replace(sNewValue, sOldValue, "") 
     lStart = InStr(sNewValue, sDifference) 
     lLength = Len(sDifference) 
     If Target.Font.ColorIndex = 3 Then 
      lColorIndex = 5 
     Else 
      lColorIndex = 3 
     End If 
     Target.Characters(Start:=lStart, Length:=lLength).Font.ColorIndex = lColorIndex 
    End If 

    On Error GoTo 0 
    Exit Sub 

ERROR_HANDLER: 
    Select Case Err.Number 
     'I haven't added error handling - trap any errors here. 
     Case Else 
      MsgBox "Error " & Err.Number & vbCr & _ 
       " (" & Err.Description & ") in procedure Sheet1.Worksheet_Change." 
    End Select 

End Sub 

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then 
     sOldValue = Target.Value 
    End If 
End Sub 

編集：これは連続した文字列でのみ機能します。たぶんsOldValueとsNewValueの各文字を見るように変更し、必要に応じて色を変更することができます。

Answer 3

それは面倒です：

1. は、細胞が元の内容を取得するために使用UnDo
2. 関心の範囲内で変更されたことを検出
3. 使用ReDo
4. は、それらを比較し、新たなコンテンツを取得します変更された文字を取得する
5. セルのCharactersプロパティを使用して、新しい文字をフォーマットします。

UnDoを使用して、100個のセルそれぞれをstaticコピーしないようにします。ここで

Answer 4

は、私が一緒に入れて何：

Dim oldString$, newString$ 

Private Sub Worksheet_Change(ByVal Target As Range) 

    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then 
    newString = Target.Value 
     If Target.Font.ColorIndex = 3 Then 
      Target.Font.ColorIndex = 5 
     Else 
      Target.Font.ColorIndex = 3 
     End If 
    End If 
Debug.Print "New text: " & newString 
color_New_Text oldString, newString, Target 
End Sub 

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range) 
    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then 
     oldString$ = Target.Value 
     Debug.Print "Original text: " & oldString$ 
    End If 
End Sub 

Sub color_New_Text(ByVal oldString As String, ByVal newString As String, ByVal theCell As Range) 
Dim oldLen&, newLen&, i&, k& 
oldLen = Len(oldString) 
newLen = Len(newString) 

Debug.Print newString & ", " & oldString 
For i = 1 To newLen 
    If Mid(newString, i, 1) <> Mid(oldString, i, 1) Then 
     Debug.Print "different" 
     Debug.Print theCell.Characters(i, 1).Text 
     If theCell.Characters(i, 1).Font.ColorIndex = 3 Then 
      theCell.Characters(i, 1).Font.ColorIndex = 5 
     Else 
      theCell.Characters(i, 1).Font.ColorIndex = 3 
     End If 
    End If 
Next i 

End Sub 

それが文字列を取得するために2つのグローバル変数、Worksheet_SelectionChangeとWorksheet_Changeです。

Answer 5

あなたがここで答えを見つけることができます

Private Sub Worksheet_Change(ByVal Target As Range) 
    Dim newvalue As String 
    Dim olvalue As String 
    Dim content 
    Application.EnableEvents = False 
    If Not Intersect(Target, Range("A1:A100")) Is Nothing Then 
     If Target.Font.ColorIndex <> -4105 Or IsNull(Target.Font.ColorIndex) = True Then 
      newvalue = Target.Value 
      Application.Undo 
      oldvalue = Target.Value 
      Content = InStr(newvalue, Replace(newvalue, oldvalue, "")) 
      Target.Value = newvalue 
      With Target.Characters(Start:=Content, Length:=Len(newvalue)).Font 
       .Color = 5 
      End With 
     Else 
      Target.Font.ColorIndex = 3 
     End If 
    End If 
    Application.EnableEvents = True 
End Sub