Partial change font colour within cell - VBA

[jimsjams]

A friend wanted help to write a macro to change the text colour (to turn blue text to black and red text to blue) I thought I could help and so made this:

Sub changecol()

For Each Cell In Selection
If Cell.Font.ColorIndex = 37 Then
Cell.Font.ColorIndex = 1
End If
Next

For Each Cell In Selection
If Cell.Font.ColorIndex = 3 Then
Cell.Font.ColorIndex = 37
End If
Next

End Sub

I then found out that his cells had multiple font colours within in them (blue, black and red) and only part of the cell text should be changed.

This is much more complicated. I was wondering whether there is a way to use the cell.characters.font property to count the starting character number and length of say the blue text in order to convert it to black.

Would this even be possible?

Any thoughts greatly appreciated!

Thanks,

James

 

[westconn1]

probably just loop through all the characters and change those matching the colour, probably faster than trying to find starts and ends, especially if there could be be more than 1 red word (or whatever), not consecutive, in a cell

 

[jimsjams]

Hi,

Thanks for the reply. That makes much more sense - much more logical.

I had a go at it and got this:


Sub changecharctercolv2()
For Each cell In Selection
For i = 1 To Len(cell)
If cell.Characters(i, 1).Font.ColorIndex = 37 Then
cell.Characters(i, 1).Font.ColorIndex = 1
End If
Next
For i = 1 To Len(cell)
If cell.Characters(i, 1).Font.ColorIndex = 3 Then
cell.Characters(i, 1).Font.ColorIndex = 37
End If

Next
Next

It seems to work. Not sure if my loop is very good logic though.

Thanks,

James

 

[RoryA]

You only need to loop each cell once:

For Each cell In Selection
   For i = 1 To Len(cell)
      If cell.Characters(i, 1).Font.ColorIndex = 37 Then
         cell.Characters(i, 1).Font.ColorIndex = 1
      ElseIf cell.Characters(i, 1).Font.ColorIndex = 3 Then
         cell.Characters(i, 1).Font.ColorIndex = 37
      End If
   Next i
Next cell

 

[Phil Smith]

I found this post through Google and have tried to adapt it to change just the first and last characters in a cell.

The cell(s) in question contain dates and if any of them match a list in a Range called PayDays, a "£" followed by 2 spaces is inserted immediately before the date and then immediately after the date is another two spaces followed by another "£". It is the "£" characters that I wish to change into red and bold.

The code I have so far is as follows:

.Cells(r - 1, 13) = "£  " & Format(.Cells(r - 1, 13).Value, "d mmm") & "  £"
 
lastchr = Len(.Cells(r - 1, 13))
 
With .Cells(r - 1, 13).Characters(, 1).Font
 
.Bold = True
 
.Color = RGB(255, 0, 0)
 
 End With
 
With .Cells(r - 1, 13).Characters(lastchr, 1).Font
 
 .Bold = True
 
 .Color = RGB(255, 0, 0)
 
End With

The cell is changed to show the "£" before and after the date with no problems, however ALL the text into red and bold, not just the first and last characters, "£", as I intended.

Any pointers as to how, or even if, this is possible to achieve?

 

[Andrew Poulsom]

Your code worked perfectly for me. What's in the cell when it fails for you?

 

[Phil Smith]

For example, the first cell that is changed contains the date 11/11/2011 formatted as "11 Nov".

My code then adds the "£" so it reads "£ 11 Nov £".

After that though, EVEYTHING is formatted red and bold, not just the "£" characters.

The fact that it worked for you has REALLY stumped me!

 

[Andrew Poulsom]

I should have said it works for me in Excel 2003. I don't have Excel 2010 available where I am at the moment so I can't test it.

 

[jbeaucaire]

Try this:

Sub Format_Characters_In_Found_Cell()
Dim Found As Range, x As String, FoundFirst As Range

x = "£"
On Error Resume Next
Set Found = Cells.Find(what:=x, LookIn:=xlValues, LookAt:=xlPart)

If Not Found Is Nothing Then
    Set FoundFirst = Found
    Do
      'Format "x"
        With Found.Characters(Start:=InStr(Found.Text, x), Length:=Len(x))
            .Font.ColorIndex = 3
            .Font.Bold = True
        End With
        With Found.Characters(Start:=InStrRev(Found.Text, x), Length:=Len(x))
            .Font.ColorIndex = 3
            .Font.Bold = True
        End With
        Set Found = Cells.FindNext(Found)
    Loop Until FoundFirst.Address = Found.Address
Else
    MsgBox x & " could not be found.", , " "
End If

End Sub

Before: £ 11 Nov £

After: £ 11 Nov £

 

[Biz]

Try this:

Sub Format_Characters_In_Found_Cell()
Dim Found As Range, x As String, FoundFirst As Range
 
x = "£"
On Error Resume Next
Set Found = Cells.Find(what:=x, LookIn:=xlValues, LookAt:=xlPart)
 
If Not Found Is Nothing Then
    Set FoundFirst = Found
    Do
      'Format "x"
        With Found.Characters(Start:=InStr(Found.Text, x), Length:=Len(x))
            .Font.ColorIndex = 3
            .Font.Bold = True
        End With
        With Found.Characters(Start:=InStrRev(Found.Text, x), Length:=Len(x))
            .Font.ColorIndex = 3
            .Font.Bold = True
        End With
        Set Found = Cells.FindNext(Found)
    Loop Until FoundFirst.Address = Found.Address
Else
    MsgBox x & " could not be found.", , " "
End If
 
End Sub

Before: £ 11 Nov £

After: £ 11 Nov £

Nice method.

Biz