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

admin管理员组

文章数量:1312680

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

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

• excel
• vba

Share Improve this question Follow edited Feb 8 at 19:19 Zion ToDo asked Jan 31 at 15:24 Zion ToDoZion ToDo 1355 bronze badges 10

• Please edit your question instead of adding information in comments where it is hard to parse and may be missed. See here for how to make a table – cybernetic.nomad Commented Jan 31 at 15:49
• Your code seems to work OK here, but I cannot test in on 2007 – Ron Rosenfeld Commented Jan 31 at 18:01
• It works in 2021. So what is the issue - error message, wrong result, nothing happens? – June7 Commented Jan 31 at 18:15
• @June7 - the error in in the first para of the post – Tim Williams Commented Jan 31 at 18:17
• FYI not sure if supported in 2007 but Cell.HasFormula is an easier way to check if there's a formula in the cell. – Tim Williams Commented Jan 31 at 18:18

 |  Show 5 more comments

1 Answer 1

Sorted by: Reset to default 1

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.

For the various arguments you can pass to Value:
https://learn.microsoft/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

本文标签：