如何用Excel VBA仅重着色指定日期并排除特定数字（兼容2007）

需求说明 #

• 处理对象：Excel单元格内黑色（RGB(0,0,0)）的指定格式日期，需将其改为蓝色（RGB(0,112,192)）
• 支持的日期格式：d/m、dd/m、d/mm、dd/mm、d/m/yy、dd/m/yy、d/mm/yy、dd/mm/yy、d/m/yyyy、dd/m/yyyy、d/mm/yyyy、dd/mm/yyyy
• 限制规则：
  • 忽略日期前的单个0
  • 忽略日期后的任意两位数字
  • 日期后紧跟空格，或紧跟下标格式30中的数字3、5、6时，不将这些后续字符误判为日期的一部分
• 适用版本：Microsoft Office 2007

原代码 #

Sub TestDateRecoloring()

    '### adjust these colors to suit your purpose ###
    Const FIND_CLR As Long = vbBlack  'look for "date-like" text with this color
    Const NEW_CLR As Long = vbBlue  '...and recolor the text using this color
    
    Dim c As Range
    
    For Each c In ActiveSheet.UsedRange.EntireRow.Columns("J").Cells
        RecolorDates c, FIND_CLR, NEW_CLR
    Next c
    
End Sub

Sub RecolorDates(c As Range, clr As Long, clrNew As Long)
    
    Dim col As New Collection, i As Long, iStart As Long, iLen As Long
    Dim v As String, ch As String, itm
    
    v = c.Value
    If Len(v) = 0 Then Exit Sub               'skip empty cells
    If c.HasFormula Then Exit Sub             'skip formulas
    
    For i = 1 To Len(v) 'loop over characters in cell content
        ch = Mid(v, i, 1)
        If ch = "/" Or ch Like "#" Then 'could be a character in a date?
            If c.Characters(i, 1).Font.Color = clr Then
                If iStart = 0 Then iStart = i 'save start of this run
                iLen = iLen + 1               'increment run length
            Else
                'wrong color so add any existing run
                AddAnyRun col, c, iStart, iLen
            End If
        Else
            'not a "date character" so add any existing run
            AddAnyRun col, c, iStart, iLen
        End If
    Next i
    AddAnyRun col, c, iStart, iLen 'add any remaining run
    
    For Each itm In col 'recolor all matched runs
        If itm.Text Like "*#/#*" or itm.Text Like "*##/#*" or itm.Text Like "*#/##*" or itm.Text Like "*##/##*" or itm.Text Like "*#/#/##" or itm.Text Like "*##/#/##" or itm.Text Like "*##/##/##" or itm.Text Like  "*##/##/##" or itm.Text Like "*#/#/####" or itm.Text Like "*##/##/####" or itm.Text Like "*#/##/####" or itm.Text Like "*##/##/####" Then itm.Font.Color = clrNew
    Next itm
End Sub

'add run of characters from cell `c` to `col` and reset `iStart` and `iLen`
Sub AddAnyRun(col As Collection, c As Range, ByRef iStart As Long, ByRef iLen As Long)
    If iLen > 2 Then col.Add c.Characters(iStart, iLen) 'if more than 2 characters then recolor the run
    iLen = 0       'reset start position and length
    iStart = 0
End Sub

优化后的代码 #

Sub TestDateRecoloring()
    ' 定义颜色常量（精确匹配目标RGB值）
    Const FIND_CLR As Long = &H0 ' RGB(0,0,0) 黑色
    Const NEW_CLR As Long = &H7000C0 ' RGB(0,112,192) 蓝色
    
    Dim c As Range
    ' 仅遍历J列已使用区域，提升处理效率
    For Each c In Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("J"))
        RecolorDates c, FIND_CLR, NEW_CLR
    Next c
End Sub

Sub RecolorDates(c As Range, clr As Long, clrNew As Long)
    Dim regex As Object
    Dim matches As Object, match As Object
    Dim v As String, charPos As Long
    Dim followLen As Integer, followChar As String
    
    Set regex = CreateObject("VBScript.RegExp")
    v = c.Value
    
    ' 跳过空单元格和含公式的单元格
    If Len(v) = 0 Or c.HasFormula Then Exit Sub
    
    ' 正则表达式匹配目标日期格式，排除前置单个0
    regex.Pattern = "(?!0)(\d{1,2}/\d{1,2}(?:/\d{2,4})?)"
    regex.Global = True
    
    Set matches = regex.Execute(v)
    
    For Each match In matches
        charPos = match.FirstIndex + 1 ' VBA字符索引从1开始
        followLen = Len(match.Value)
        
        ' 先检查匹配文本是否为黑色
        If c.Characters(charPos, followLen).Font.Color = clr Then
            ' 检查后续字符是否符合跳过规则
            If charPos + followLen <= Len(v) Then
                ' 规则1：跳过日期后的任意两位数字
                If Mid(v, charPos + followLen, 2) Like "##" Then
                    GoTo SkipCurrentMatch
                End If
                
                followChar = Mid(v, charPos + followLen, 1)
                ' 规则2：日期后紧跟空格，仅着色日期本身
                If followChar = " " Then
                    c.Characters(charPos, followLen).Font.Color = clrNew
                    GoTo SkipCurrentMatch
                End If
                
                ' 规则3：日期后紧跟下标格式30的数字3、5、6
                If followChar Like "[356]" Then
                    If charPos + followLen + 1 <= Len(v) Then
                        If c.Characters(charPos + followLen, 2).Font.Subscript = True Then
                            GoTo SkipCurrentMatch
                        End If
                    End If
                End If
            End If
            ' 符合所有条件，执行着色
            c.Characters(charPos, followLen).Font.Color = clrNew
        End If
SkipCurrentMatch:
    Next match
End Sub

优化说明 #

1. 精准匹配：用正则表达式替代字符遍历，直接锁定目标日期格式，避免非日期的数字/斜杠组合被误处理
2. 效率提升：仅遍历J列已使用区域，减少无效单元格的循环处理
3. 规则适配：
   • 通过正则前缀(?!0)排除日期前的单个0
   • 增加后续字符检查逻辑，跳过日期后的两位数字、紧跟空格或下标30的3/5/6
   • 使用精确RGB值定义颜色，避免vbBlue与目标颜色的差异
4. 版本兼容：采用CreateObject创建正则对象，无需提前引用库，适配Office 2007

示例数据 #

注：最后一行中630(1-1-1-vomiting)里的30为下标格式；示例中加粗内容在原Excel中为黑色未加粗文本，需重着色为蓝色。

内容的提问来源于stack exchange，提问作者Zion ToDo