excelvba

How to change Font Color of dates without changing color of other text or background using VBA for Excel


I am trying to change the font color of dates without changing the color of the other text or background using VBA for Excel but there is a bug in what I have. I am getting the error,

Run-time error '1004': Unable to get the Characters property of the Range class.

As per Google, a "Run-time error '1004': Unable to get the Characters property of the Range class" in Excel VBA means that your code is trying to access the characters within a cell range, but either the range is not selected correctly, is empty, or contains a data type that doesn't support character manipulation, causing an error when trying to use the "Characters" property.

I am trying to change blue colored dates [(RGB(0, 112, 192)] to light blue [RGB(173, 216, 230)]. 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:-

Option Explicit


 
 
Public Sub ChangeBlue()

   Dim DarkBlue As Long
   Dim LightBlue As Long
   Dim Cell As Range
   Dim C As Long
   
   DarkBlue = RGB(0, 112, 192)
   LightBlue = RGB(173, 216, 230)
   
   Application.ScreenUpdating = False
   
   For Each Cell In Intersect(ActiveSheet.UsedRange, ActiveSheet.Range("J:J"))
      'If Not IsEmpty(Cell) And Not Application.WorksheetFunction.IsFormula(Cell)  And InStr(1, Cell, "/") Then ' for Excel 2016 and later
      If Not IsEmpty(Cell) And Left(Cell.Formula, 1) <> "=" And InStr(1, Cell, "/") Then
If Cell.Row Mod 100 = 0 Then Application.StatusBar = Cell.Address
         For C = 1 To Len(Cell.Value)
            If Cell.Characters(Start:=C, Length:=1).Font.Color = DarkBlue Then
               Cell.Characters(Start:=C, Length:=1).Font.Color = LightBlue
            End If
         Next C
      
      End If
   
   Next Cell

   Application.ScreenUpdating = True
Application.StatusBar = False
End Sub

How to Debug the above?

Sample data:-
Kali Bichrom.200(BHP)+Ant.crud.200(eczema)+45 200(arthralgia)2/9/2448 200+6 200+3 200(cough)+6 30(1-1-1-vomiting)5/96 1M17/126 200+6 1M15/1/20256 10M
37 20016/548 200+6 20025/548 1M+6 1M
19/548 200+Lyco.200+6 20025/548 1M+6 1M

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

I am using Microsoft Office 2007, so please keep that in mind. For your information, every date is presently blue or light blue in color


Solution


If all you need to do is replace the light blue color with a different one in any cell with a forward slash then this would work:

Sub RecolorText()
   
   Dim c As Range, rngData As Range, v
   
   For Each c In ActiveSheet.UsedRange.EntireRow.Columns("J").Cells
        If Not c.HasFormula Then
            v = c.Value
            If Len(v) > 0 And InStr(v, "/") > 0 Then
                
                c.Value(11) = Replace(c.Value(11), _
                     "Color=""#44B3E1""", "Color=""#FF0000""")
            
            End If
        End If 'has formula
   Next c
End Sub

You'll need to get the "old" and "new" colors by selecting a cell then in the Immediate pane enter ? Selection.Value(11) and check the required color values (see example output below). Above the code is replacing a light blue with red.

example XML

For the various arguments you can pass to Value:
https://learn.microsoft.com/en-us/office/vba/api/excel.xlrangevaluedatatype

EDIT: for completeness here is a different approach with a bit more checking, using the original Characters-based method:

Sub TestDateRecoloring()

    '### adjust these colors to suit your purpose ###
    Const FIND_CLR As Long = vbRed  '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.Range("A1:A7").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
    If Not IsNull(c.Font.Color) Then Exit Sub 'cell has no mixed color formatting
    
    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
        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