I am trying to recolor black colored dates [(RGB(0, 0, 0)] without recoloring the other text or numbers using VBA for Excel to blue [RGB(0, 112, 192)]. The dates are in the format d/m, dd/m, d/mm, dd/mm, d/m/yy, dd/m/yy, d/mm/yy, dd/mm/yy and d/m/yyyy, dd/m/yyyy, d/mm/yyyy, dd/mm/yyyy with other text, both before and after the dates. I tried to do that with this VBA code, but it needs some tweaking. What can I add to skip recoloring a 0 (zero) if it is just before a date, skip recoloring every two digit number after a date and skip recoloring numbers 3, 5 and 6 after a date if they are followed by a space or number 30 in subscript format?

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

I am trying to recolor black colored dates [(RGB(0, 0, 0)] without recoloring the other text or numbers using VBA for Excel to blue [RGB(0, 112, 192)]. The dates are in the format d/m, dd/m, d/mm, dd/mm, d/m/yy, dd/m/yy, d/mm/yy, dd/mm/yy and d/m/yyyy, dd/m/yyyy, d/mm/yyyy, dd/mm/yyyy with other text, both before and after the dates. I tried to do that with this VBA code, but it needs some tweaking. What can I add to skip recoloring a 0 (zero) if it is just before a date, skip recoloring every two digit number after a date and skip recoloring numbers 3, 5 and 6 after a date if they are followed by a space or number 30 in subscript format?

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

Note: The 30 in 630(1-1-1-vomiting) in the last line is in subscript format

Whatever is in bold is actually black but not in bold in the original excel sheet and I want to recolor it blue

I am using Microsoft Office 2007, so please keep that in mind.

• excel
• vba
• date

• 1 Did you already ask this question? – cybernetic.nomad Commented Feb 6 at 20:48
• @cybernetic.nomad - yes, but the discussion got unwieldy so I suggested a new question with more-specific requirements... – Tim Williams Commented Feb 6 at 21:46
• Are the bolded sections the only black text? – Tim Williams Commented Feb 6 at 21:48
• No, there are other numbers and words in black (color) as well. – Zion ToDo Commented Feb 6 at 22:18
• Your date formats are too numerous and having potential digits before and after a date makes getting this 100% correct a bit tedious (a whole lot of if/then and testing different scenarios), so a full answer would be a lot of work. – Tim Williams Commented Feb 7 at 1:11

1 Answer 1

You can use regular expressions in VBA to return the substrings you consider dates, and then apply the formatting.

You gave no rules as to the allowable date range. Examining your data showed that a range of 2000-2039 might be appropriate but this could be adjusted in the regex.

Be sure to set the VBA reference (see first line/comment in the code)
Note that I used RED/BOLD for the font as it displays better in the screenshot. You should change that to your desired DarkBlue

'Set reference to Microsoft VBScript Regular Expressions 5.5
Option Explicit
Public Sub ChangeBlue()
   Dim DarkBlue As Long
   Dim LightBlue As Long
   Dim Cell As Range
   Dim C As Long
   
   Dim RE As RegExp, MC As MatchCollection, M As Match
   
   DarkBlue = RGB(0, 112, 192)
   LightBlue = RGB(173, 216, 230)
   
'Initialize Regular Expressions to look for properly formatted dates
'Note this will only include years from 2000-2039 but can be modified to include a wider range

Set RE = New RegExp
With RE
    .Global = True
    .MultiLine = True
    .Pattern = "(?:3[01]|[12][0-9]|0?[1-9])/(?:1[0-2]|0?[1-9])(?:/(?:20[0-9]\d|[0-3]\d))?"
End With

For Each Cell In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("J:J"))
    If Not Cell.HasFormula Then
        If RE.Test(Cell.Value) Then
        
        'remove existing font formats
            With Cell
                .Font.Bold = False
                .Font.Color = vbBlack
            End With
              Set MC = RE.Execute(Cell.Value)
              For Each M In MC
                    With Cell.Characters(M.FirstIndex + 1, M.Length).Font
                      .Color = vbRed 'change to dark blue for use
                      .Bold = True   'optional
                    End With
            
            Next M
        End If
    End If
Next Cell


End Sub