如何从 VBA 中生成的 Excel 公式对单元格中的部分文本应用/更改颜色？

Question

我在Excel单元格B12中有这样的语句，它实际上是一个非常复杂的Excel公式的结果值： ”● 截至2024年1月23日，全国月平均气温10.12℃，比月平均气温10.98℃低-0.86℃，并略有下降。↓”

现在，我想将“较冷”和“稍微减少”文本的颜色更改为蓝色。我已经开发了一个 VBA 代码，但它在仅包含值的单元格上运行

并且它不在包含 Excel 公式的单元格上运行。

我的VBA代码如下：

Sub HighlightKeywordsDynamically()
    Dim rngCell As Range
    Dim newText As String
    Dim keywordPos As Long
    Dim keyword As String
    Dim i As Integer

    ' Set the target range from B392 to B412
    Set rngCell = Range("B392:B412")

    ' Arrays of keywords and their corresponding colors
    Dim blueKeywords As Variant
    blueKeywords = Array("slightly decreasing", "significantly decreasing", "sharply decreasing", "below average", "coldest place", "coldest night", "coldest day", "smallest diurnal", "cooler")

    Dim redKeywords As Variant
    redKeywords = Array("slightly increasing", "significantly increasing", "sharply increasing", "above average", "hottest place", "hottest night", "hottest day", "largest diurnal", "warmer")

    ' Loop through each cell in the range
    For Each cell In rngCell
        ' Get the formula text from the cell
        newText = cell.Formula

        ' Loop through blue keywords
        For i = LBound(blueKeywords) To UBound(blueKeywords)
            keyword = blueKeywords(i)
            keywordPos = InStr(1, newText, keyword, vbTextCompare)
            If keywordPos > 0 Then
                ' Check for specific keywords to apply the logic of 9 characters before
                If keyword = "cooler" Then
                    cell.Characters(Start:=keywordPos - 9, Length:=Len(keyword) + 9).Font.Color = RGB(0, 0, 255) ' Blue
                Else
                    cell.Characters(Start:=keywordPos, Length:=Len(keyword)).Font.Color = RGB(0, 0, 255) ' Blue
                End If
            End If
        Next i

        ' Loop through red keywords
        For i = LBound(redKeywords) To UBound(redKeywords)
            keyword = redKeywords(i)
            keywordPos = InStr(1, newText, keyword, vbTextCompare)
            If keywordPos > 0 Then
                ' Check for specific keywords to apply the logic of 9 characters before
                If keyword = "warmer" Then
                    cell.Characters(Start:=keywordPos - 9, Length:=Len(keyword) + 9).Font.Color = RGB(255, 0, 0) ' Red
                Else
                    cell.Characters(Start:=keywordPos, Length:=Len(keyword)).Font.Color = RGB(255, 0, 0) ' Red
                End If
            End If
        Next i
    Next cell
End Sub                     

我开发了在包含文本的单元格上运行的 VBA 代码。 我需要对代码提出建议或修改，以在公式的结果值上得出所需的结果

Answer 1

您可以使用

Change

和

BeforeDoubleClick

（或

BeforeRightClick

）例程隐藏笔记中的公式。
当您在单元格中编辑公式并提交编辑时，

Change

过程会将公式复制到注释并将值保留在单元格中。
您现在可以使用例程设置该值的格式（调整为单个单元格）。

当您在之前有公式并已存储的单元格上使用

DoubleClick

时，它会被恢复，以便您可以对其进行编辑。提交后，单元格中会再次出现一个值，并且公式将转到注释中。

这样做的缺点是，如果您在公式中使用相对引用，则引用（存储在注释中）不会像复制公式时那样做出反应。如果您想执行此类复制，您需要暂时禁用

Change

事件处理程序。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    With Target
        If .Comment Is Nothing Then Exit Sub
        Application.EnableEvents = False
        If .Comment.Text Like "=*" Then _
           .Formula = .Comment.Text
        Application.EnableEvents = True
        .Comment.Delete
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    With Target
        If .CountLarge > 1 Then Exit Sub
        If .HasFormula Then
            On Error Resume Next
            .AddComment
            On Error GoTo 0
            .Comment.Visible = False
            .Comment.Text Text:=.Formula
            .Comment.Shape.TextFrame.AutoSize = True
            Application.EnableEvents = False
            .Value = .Value
            Application.EnableEvents = True
            ' here goes a procedure to display text with characters' formatting
        End If
    End With
    Application.DisplayCommentIndicator = xlNoIndicator
End Sub