How to extract text of some color from single cell?

[roberto.delagarza]

I need to extract some text from singe cells wich has been marked with another color, let's say red. Do you have a simple vba macro subroutine which can extract the text and write it in another cell? I will apply this sobroutine in the entire database field. Sometimes the text is contiguos in the cell, sometimes it isn't. Thanks !!

 

[Scott Huish]

Hi, welcome to the board!

Function GetColorText(r As Range) As String
Dim s As String, t As String, x As Long
t = r.Text
For x = 1 To Len(t)
    If r.Characters(x, 1).Font.Color = vbRed Then s = s & Mid(t, x, 1)
Next
GetColorText = s
End Function

 

[roberto.delagarza]

Thank you very much. It will be a very time-consuming task to separate the different text according to its color. I could modificate your Function and separate red color and black color and it was very easy. Again thanks. I imaginate it will be a way in vba to make it but I recognize I was far from solve the problem of build the macro.

 

[Scott Huish]

If you need it to return everything that is not black, no matter what the other color is, try this:

Function GetColorText(r As Range) As String
Dim s As String, t As String, x As Long
t = r.Text
For x = 1 To Len(t)
    If r.Characters(x, 1).Font.Color <> vbBlack Then s = s & Mid(t, x, 1)
Next
GetColorText = s
End Function

 

[madhav_kulkarni]

If you need it to return everything that is not black, no matter what the other color is, try this:

Function GetColorText(r As Range) As String
Dim s As String, t As String, x As Long
t = r.Text
For x = 1 To Len(t)
    If r.Characters(x, 1).Font.Color <> vbBlack Then s = s & Mid(t, x, 1)
Next
GetColorText = s
End Function

The code extracts colored text but without space between two words in case the words are away from each other.

Please help with a solution which would keep the words separate.

 

[Rick Rothstein]

The code extracts colored text but without space between two words in case the words are away from each other.

Please help with a solution which would keep the words separate.

If all the letters within any single word are always the same color (that is, no single word has two or more differently colored letters), then this UDF (user defined function) should be faster than the one Scott posted in Message #4 and it puts a space between each returned word.

[table="width: 500"]
[tr]
	[td]Function GetColorText(R As Range) As String
  Dim X As Long, Pos As Long, Words() As String
  Words = Split(R.Text)
  Pos = 1
  For X = 0 To UBound(Words)
    If R.Characters(Pos, 1).Font.Color <> vbBlack Then GetColorText = GetColorText & " " & Words(X)
    Pos = Pos + Len(Words(X)) + 1
  Next
  GetColorText = Trim(GetColorText)
End Function[/td]
[/tr]
[/table]

 

[madhav_kulkarni]

If all the letters within any single word are always the same color (that is, no single word has two or more differently colored letters), then this UDF (user defined function) should be faster than the one Scott posted in Message #4 and it puts a space between each returned word.

[TABLE="width: 500"]
<tbody>[TR]
[TD]Function GetColorText(R As Range) As String
  Dim X As Long, Pos As Long, Words() As String
  Words = Split(R.Text)
  Pos = 1
  For X = 0 To UBound(Words)
    If R.Characters(Pos, 1).Font.Color <> vbBlack Then GetColorText = GetColorText & " " & Words(X)
    Pos = Pos + Len(Words(X)) + 1
  Next
  GetColorText = Trim(GetColorText)
End Function
[/TD]
[/TR]
</tbody>[/TABLE]

Amazing stuff! Really worked much faster that earlier codes.. Thanks Rick.

 

[madhav_kulkarni]

Rick, Great Stuff!!! as usual..

 

[Alanacran]

If all the letters within any single word are always the same color (that is, no single word has two or more differently colored letters), then this UDF (user defined function) should be faster than the one Scott posted in Message #4 and it puts a space between each returned word.

[table="width: 500"]
[tr]
    [td]Function GetColorText(R As Range) As String
  Dim X As Long, Pos As Long, Words() As String
  Words = Split(R.Text)
  Pos = 1
  For X = 0 To UBound(Words)
    If R.Characters(Pos, 1).Font.Color <> vbBlack Then GetColorText = GetColorText & " " & Words(X)
    Pos = Pos + Len(Words(X)) + 1
  Next
  GetColorText = Trim(GetColorText)
End Function[/td]
[/tr]
[/table]

Rick this is exactly what I have been looking for !!!!! Thank you so much. But I am now having problems when trying to add ElseIf into the VBA. I have multiple colors I need to look for and extract not just one. Help !!!!!!

 

[Rick Rothstein]

Tell us all of the colors and what should or should not happen for each of them.