Copy only the text of a certain color from a cell

Hi everyone!

I have an Excel problem which I have been trying to solve for a while but so far I have had no luck. A friend recommended this forum, so I am really hoping you guys can help!

I need a VBA script that can copy only text that has a font color of red from a cell. The cell has both black and red text. I then need to copy the result into an adjacent cell.

An Example (A1):-

This is an example of a cells content.

It has both red and black text.


I want the macro to search through column A and copy only the text in each cell that is red.

The result in (B1) will be:-

example of a cells

red


Could anyone help me?

Many thanks in advance!

Mark

Hi
try this user-defined function
it assumes the "red" you are refering to is the standard colour red RGB(255,0,0)
if not, you'll have to tweak it to reflect the colour your are using (there are thousands of variants of "red"!)

Function extract_colour(rng As Range)
Dim FontCol, x As Long, txt As String
FontCol = RGB(255, 0, 0)
txt = ""

For x = 1 To rng.Characters.Count
    If rng.Characters(x, 1).Font.Color = FontCol Then txt = txt & rng.Characters(x, 1).Text
Next x

If Len(txt) > 0 Then ActiveCell.Font.Color = FontCol Else ActiveCell.Font.Color = xlAutomatic
extract_color = txt

End Function

if you are not familiar with user-defined functions, this is what you do:

To copy and use a user-defined formula
press alt+F11 to open the VBA area
select insert > module
copy the code from this website and paste it into the VBA module you just inserted
Return to the spreadheet. You now have a new formula that works like the inbuilt formulas such as =SUM()
In cell B1, type:
=extract_colour(A1)
The formula should copy the red characters

Function extract_color(rng As Range)
    Dim FontCol, x As Long, txt As String
    FontCol = RGB(255, 0, 0)
    txt = ""

    For x = 1 To rng.Characters.Count
        If rng.Characters(x, 1).Font.Color = FontCol Then txt = txt & rng.Characters(x, 1).Text
    Next x

    If Len(txt) > 0 Then ActiveCell.Font.Color = FontCol Else ActiveCell.Font.Color = xlAutomatic
    extract_color = txt

End Function

Hi angrygorilla and NickyC

I have made a small change to the macro from Nicky. There was a typo in the code - color was spelled two ways!

Regards, David


When you reply please make it clear WHO you are responding to by mentioning their name.
If this has been of assistance, please advise. A little thanks goes a long way.
- Please click on the *Add Reputation button at the bottom of helpful responses.
Please mark your thread as SOLVED:
- Click Thread Tools above your first post, select "Mark your thread as Solved".

thanks David - I get my Aussie and Excel spellings mixed up sometimes