VBA-更改修改文本的颜色

我有一段代码，如果单元格中的文本被修改，它会改变文本的颜色。然而，我正在研究一些只改变单元格内修改文本颜色的东西。例如，我在单元格A1中有“This cell”，当我将其更改为“This cell-This is new text”时，“我只想更改颜色”-This is new text”

---

谢谢

这将更改字体，但它并不完美。如果在同一单元格中有不同的字体颜色，则

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

中的每个字符，并根据需要更改颜色。

这很费劲：

检测感兴趣范围内的单元格是否已更改

使用

UnDo

获取原始内容

使用

ReDo

获取新内容

比较它们以获得更改的字符

使用单元格的

Characters

属性格式化新字符

---

我会使用

UnDo

来避免保留100个单元格中每个单元格的

静态副本

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

Dim oldString$，新闻字符串$
私有子工作表_更改（ByVal目标作为范围）
如果不相交（目标，范围（“A1:A100”））则为零
newString=Target.Value
如果Target.Font.ColorIndex=3，则
Target.Font.ColorIndex=5
其他的
Target.Font.ColorIndex=3
如果结束
如果结束
调试。打印“新文本：”&新闻字符串
颜色\新\文本旧字符串、新闻字符串、目标
端接头
专用子工作表\u选择更改（以Excel.Range形式显示的ByVal目标）
如果不相交（目标，范围（“A1:A100”））则为零
oldString$=Target.Value
调试。打印“原始文本：”&oldString$
如果结束
端接头
子颜色\新\文本（ByVal oldString作为字符串，ByVal newString作为字符串，ByVal theCell作为范围）
Dim oldLen&，newLen&，i&，k&
oldLen=Len（oldString）
newLen=Len（newString）
调试。打印新闻字符串&“，”&旧字符串
对于i=1到newLen
如果Mid（newString，i，1）Mid（oldString，i，1），那么
调试。打印“不同”
调试。打印cell.Characters（i，1）。文本
如果cell.Characters（i，1）.Font.ColorIndex=3，则
cell.Characters（i，1）.Font.ColorIndex=5
其他的
cell.Characters（i，1）.Font.ColorIndex=3
如果结束
如果结束
接下来我
端接头

这是两个全局变量，一个
工作表\u selection Change
和
工作表\u Change
来获取字符串。
使用Gary学生的提示，我保留单元格的旧值并与新值进行比较。然后使用长度获得“差异”并给“字符”上色。修改如下：

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

选项显式
作为变体的公共价值
公共子工作表\u选择更改（ByVal目标作为范围）
oldValue=Target.Value
端接头
私有子工作表_更改（ByVal目标作为范围）
暗淡的旧颜色
如果不相交（目标，范围（“A1:A100”））则为零
如果目标值为oldValue，则
oldColor=Target.Font.ColorIndex
Target.Characters（Len（oldValue）+1，Len（Target）-Len（oldValue））.Font.ColorIndex=IIf（oldColor=3,5,3）
如果结束
如果结束
端接头

抱歉，我的英语
请尝试以下内容

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

Private子工作表\u更改（ByVal目标作为范围）
将newvalue设置为字符串
将值设置为字符串
模糊内容
Application.EnableEvents=False
如果不相交（目标，范围（“A1:A100”））则为零
如果Target.Font.ColorIndex-4105或为null（Target.Font.ColorIndex）=True，则
newvalue=Target.Value
应用程序。撤消
oldvalue=Target.Value
Content=InStr（newvalue，替换为newvalue，oldvalue，“”）
Target.Value=newvalue
使用Target.Characters（开始：=内容，长度：=Len（newvalue））.Font
.颜色=5
以
其他的
Target.Font.ColorIndex=3
如果结束
如果结束
Application.EnableEvents=True
端接头
您可以在这里找到答案：看起来不错………您是否应该在
工作表\u selection change
事件中处理的代码中的某个地方刷新
sOldValue
。更新单元格后，按enter键将移动到下一个单元格并捕获该单元格的旧值。代码良好。。。。。。。。。。。。。。但是，如果只有一个全局单元格，则可能无法保留感兴趣范围内所有单元格的旧值。谢谢！虽然如果我在单元格的开头更改某些内容，它会更改右侧字符的颜色，但它确实起作用。但不管怎样，它确实达到了目的。谢谢！
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