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

используя наконечник от ученика Гэри, я сохраняю старое значение ячейки и сравниваю его с новым значением. Затем используйте длину, чтобы получить «разницу» и покрасить «символы». Вот модификация:

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. обнаружить, что клетка изменилась в интересующем диапазоне
2. использование UnDo, чтобы получить оригинальное содержание
3. использование ReDo, чтобы получить новое содержание
4. сравнить их для получения измененных символов
5. использовать свойство ячейки Characters для форматирования новых символов

Я бы использовал UnDo, чтобы избежать хранения static копии каждого из 100 ячеек.

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 

Это две глобальные переменные, Worksheet_SelectionChange и Worksheet_Change, чтобы получить строки.

Answer 5

Try с ниже

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