excel - 基于来源自动着色文本的 VBA 代码

Question

我目前正在使用此代码根据其来源自动着色字体:

Sub Auto_Colour_Numbers()
   Dim rng As Range, rErr As Range
   On Error Resume Next
   For Each rng In Intersect(ActiveSheet.UsedRange, Selection)
       If rng.HasFormula Then
           Set rErr = Range(Mid(rng.Formula, 2, Len(rng.Formula) - 1))
           If CBool(Err) Then
               rng.Font.ColorIndex = 1 'black
           Else
               rng.Font.Color = RGB(0, 176, 80) 'green
           End If
           Err = 0
       ElseIf CBool(Len(rng.Value)) Then
           rng.Font.ColorIndex = 5 'blue
       Else
           rng.Font.ColorIndex = xlAutomatic 'default
       End If
   Next rng
   Set rErr = Nothing
End Sub

基本上，如果它只是一个硬编码数字，它将字体更改为蓝色，如果它是一个公式，则将字体更改为黑色，如果它来自另一个工作表，则将字体更改为绿色

它工作得相当好，但有一些问题:

1) 例如，如果我在单元格 A1 中有一个数字，然后将公式“=A1”放入单元格 B1，则宏会将字体变为绿色，即使它不是从单独的工作表中提取的

2)如果我有一个公式，例如“=5+5”，然后添加从另一张纸链接的单元格，使其成为例如“= 5 + 5 + Sheet2!E8”当理想情况下我希望它是绿色时它仍然会变成黑色。我在想寻找感叹号的 if 循环可能适用于此？

任何帮助将不胜感激(请假设您的答案中没有 VBA 的能力或知识，因为我对此非常陌生!)

谢谢

托马斯

Answer 1

CF 可能是可行的方法，但如果您想要 VBA 解决方案，请尝试使用工作表更改事件，以便每当您更改单元格时都会运行代码。将代码放入工作表模块中(右键单击工作表选项卡，查看代码，然后粘贴代码)。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rng As Range

For Each rng In Target
    If rng.HasFormula Then
        If InStr(rng.Formula, "!") Then
            rng.Font.Color = RGB(0, 176, 80)
        Else
            rng.Font.ColorIndex = 1
        End If
    Else
        rng.Font.ColorIndex = 5
    End If
Next rng

End Sub

如果您不希望它自动运行，只需恢复为普通子程序即可。

Sub x()

Dim rng As Range

For Each rng In Selection
    If rng.HasFormula Then
        If InStr(rng.Formula, "!") Then
            rng.Font.Color = RGB(0, 176, 80)
        Else
            rng.Font.ColorIndex = 1
        End If
    Else
        If Len(rng) > 0 Then rng.Font.ColorIndex = 5
    End If
Next rng

End Sub

第三种方法利用 SpecialCells，最大限度地减少所需的循环量。

Sub x()

Dim rng As Range, r1 As Range, r2 As Range

On Error Resume Next
Set r1 = Intersect(ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas), Selection)
Set r2 = Intersect(ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlNumbers), Selection)
On Error GoTo 0

If Not r1 Is Nothing Then
    For Each rng In r1
        If InStr(rng.Formula, "!") Then
            rng.Font.Color = RGB(0, 176, 80)
        Else
            rng.Font.ColorIndex = 1
        End If
    Next rng
End If

If Not r2 Is Nothing Then r2.Font.ColorIndex = 5

End Sub