CODEWITHSUNDEEP
vbaexcel
peetman
peetman

Reputation: 707

VBA - Change color of modified text

I have this code that changes the color of the text in a cell if it is modified. However I was looking into something that only changes the color of modified text inside the cell. For example I have in cell A1 = "This cell" and when I change it to "This cell - this is new text" I would like just to change the color of "- this is new text"

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

Thanks

Upvotes: 2

Views: 1976

Answers (5)

Karthick Gunasekaran
Karthick Gunasekaran

Reputation: 2713

Try with below

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

Upvotes: 0

Kellsens
Kellsens

Reputation: 312

using the tip from Gary's Student, I retain the old value of cell and compare with the new value. Then use the lenght to get the 'difference' and color the 'characters'. Here's the modification:

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. Sorry my english

Upvotes: 1

Gary&#39;s Student
Gary&#39;s Student

Reputation: 96753

It is laborious:

  1. detect that a cell has changed in the range of interest
  2. use UnDo to get the original contents
  3. use ReDo to get the new contents
  4. compare them to get the changed characters
  5. use the Characters property of the cell to format the new characters

I would use UnDo to avoid keeping a static copy of each of the 100 cells.

Upvotes: 2

BruceWayne
BruceWayne

Reputation: 23283

Here's what I put together:

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

It's two global variables, a Worksheet_SelectionChangeand Worksheet_Changeto get the strings.

Upvotes: 2

Darren Bartrup-Cook
Darren Bartrup-Cook

Reputation: 19767

This will change the font, but it's not perfect. Seems if you have different font colours in the same cell then Target.Font.ColorIndex returns NULL so it only works on the first change.

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

Edit: It will only work with a continuous string. Maybe can change to look at each character in sOldValue and sNewValue and change colour as required.

Upvotes: 1

Related Questions