VBA - Want to load Red colored text from a cell into an array

I want to put all the RED colored text in a cell , into an Array. Any help will be appreciated.

Below is situation -
My cell contain this text -> " This is testing to Red color. "

I want to populate an array Like , Array(0) = 'testing' and Array(1) = 'color'.

I am able to create a function which is scanning the entire cell which gives me 'testingcolor' . I am not able to identify the spaces. i will be good if this function can give me 'testing color'.Then i can scan for spaces and create the array. T

Code:

Function GetColorText(pRange As Range) As String Dim xOut As String Dim xValue As String Dim i As Long Dim j As Long xValue = pRange.Text j = VBA.Len(xValue) For i = 1 To VBA.Len(xValue) If pRange.Characters(i, 1).Font.Color = vbRed Then xOut = xOut & VBA.Mid(xValue, i, 1) End If Next GetColorText = xOut End Function

Hi enggrahul78!
Welcome to vbax forum.
something like below:

Code:

Function GetColorText(pRange As Range) As String Dim xOut As String, arr, n& Dim xValue As String Dim i As Long Dim j As Long ReDim arr(0) xValue = pRange.Text j = VBA.Len(xValue) For i = 1 To VBA.Len(xValue) If pRange.Characters(i, 1).Font.Color = vbRed Then xOut = xOut & VBA.Mid(xValue, i, 1) Else If xOut <> "" Then ReDim Preserve arr(n) arr(n) = Trim(xOut) xOut = "" n = n + 1 End If End If Next GetColorText = Join(arr, " ") End Function

Same result, less code:

Code:

Sub M_snb() MsgBox F_snb(sheet1.Cells(1)) End Sub Function F_snb(c00) For j = 1 To c00.Characters.Count If c00.Characters(j, 1).Font.Color = 255 Then F_snb = F_snb & c00.Characters(j, 1).Text Next End Function

@snb
Sorry, I didn't mean to offend you.
If none of his spaces are red fonts, your results will connect the strings together with no space.

And I also made a mistake when the last character is red.

--Okami

Code:

Function F_snb(c00) For j = 1 To c00.Characters.Count If c00.Characters(j, 1).Font.Color = 255 Or Mid(c00, j, 1) = " " Then F_snb = F_snb & Mid(c00, j, 1) Next F_snb = Application.Trim(F_snb) End Function

1 Attachment(s)

Okami, if the whole string is red yours ends up with blank cell (also the first and last rows are a bit odd):
Attachment 24100

My quick and dirty offering with minimal alterations to the original function:

Code:

Function GetColorText(pRange As Range) As String Dim xOut As String Dim xValue As String Dim i As Long Dim j As Long xValue = pRange.Text j = VBA.Len(xValue) For i = 1 To VBA.Len(xValue) If pRange.Characters(i, 1).Font.Color = vbRed Then xOut = xOut & VBA.Mid(xValue, i, 1) Else xOut = xOut & " " End If Next GetColorText = Application.Trim(xOut) End Function

@p45cal
Thank you for your correction.
I noticed my mistake near the end of work yesterday, But your method is better.:thumb

--Okami

Thanks Okami , p45cal and snb for your suggestions. I have other issue now....

Thanks Okami , p45cal and snb for your suggestions. I tried the suggestion from p45cal and it worked exactly the way i wanted. I appreciate all your help . However ,i ran into another problem. Your suggestion works fine when i am using a single cell. But my requirement changed and i had to use a merged cell now. This is not working for a merged cell. I have a function which gives me the merged cell data into a variable. I get the merged data and put it into xValue, but then i don't get the correct red colored text.

Can you guys let me know how can i make it work ?

I changed my code to a Subroutine instead of a function............don't ask me why ? Partial reason is because i wanted to pass array as a parameter and passing array to Subroutine is easy but passing array to function is a bit complex and was giving me various errors. i tried the options as highlighted in Blue color. I thought that i can get the data whatever i can and then assign it to xValue. But seems that xValue will only work when it picks the data from an individual cell using .TEXT property.

*** Note: I am able to do it somehow but i don't like the way i did it as it is just a patch. So what i did is , before calling the subroutine, i copied the merged cell data to a single cell and passed that cell to the subroutine.

When i place the below red code, immediately above my function, it works fine. :banghead:
Range("A6:E13").Select Selection.Copy
Range("P8").Select
ActiveSheet.Paste

Call GetColorText(Range("P8"), Coloredtext)

=============================

Sub GetColorText(pRange As Range, Coloredtext As String)

Dim xOut As String
Dim xValue As String
Dim i As Long
Dim j As Long
'Dim getcolortxt As String

'x = GetMergedCellValue(13, 5)
'Range("P8").Value = x

xValue = pRange.Text

'xValue = GetMergedCellValue(13, 5)

j = VBA.Len(xValue)

For i = 1 To VBA.Len(xValue)

If pRange.Characters(i, 1).Font.Color = vbRed Then
xOut = xOut & VBA.Mid(xValue, i, 1)
Else
xOut = xOut & " "
End If
Next

' GetColorText = xOut
Coloredtext = Application.Trim(xOut)

End Sub

=============================

Quote:

Originally Posted by p45cal

Okami, if the whole string is red yours ends up with blank cell (also the first and last rows are a bit odd):
Attachment 24100

My quick and dirty offering with minimal alterations to the original function:

Code:

Function GetColorText(pRange As Range) As String Dim xOut As String Dim xValue As String Dim i As Long Dim j As Long xValue = pRange.Text j = VBA.Len(xValue) For i = 1 To VBA.Len(xValue) If pRange.Characters(i, 1).Font.Color = vbRed Then xOut = xOut & VBA.Mid(xValue, i, 1) Else xOut = xOut & " " End If Next GetColorText = Application.Trim(xOut) End Function

Here is another function to try...

Code:

Function GetColorText(pRange As Range) As String Dim X As Long, Txt As String Txt = pRange.Value For X = 1 To Len(Txt) If pRange.Characters(X, 1).Font.Color <> vbRed Then Mid(Txt, X) = " " Next GetColorText = Application.Trim(Txt) End Function

1 Attachment(s)

Quote:

Originally Posted by enggrahul78

But my requirement changed and i had to use a merged cell now. This is not working for a merged cell.

I had no problems with merged cells:
Attachment 24108

Prepare a workbook with some sample strings in merged/unmerged cells, say what range you want to process and what result you're wanting and whether the result should be put back on the sheet or perhaps used by another sub for further processing.

I'd suggest keeping the GetColorText function as a function (use rothstein's, it's more straightforward) then incorporate that function in your subs. Something along the lines of:

Code:

Sub test() GetColourTexts Range("H5:H21"), ggg 'don't try non-contiguous ranges with this! Stop 'at this point ggg contains an array of your results End Sub Sub GetColourTexts(myRng As Range, myOutput) myOutput = myRng.Value For rw = 1 To UBound(myOutput) 'rows For colm = 1 To UBound(myOutput, 2) 'columns If Not IsEmpty(myOutput(rw, colm)) Then myOutput(rw, colm) = GetColorText(myRng.Cells(rw, colm)) Next colm Next rw 'at this point myOutput is an array of your results End Sub

Note I've merely added an s to the function name to get the sub name.

ps. using .Value, .Value2 or .Text (if you can) of a range returns only plain strings or numbers, there is no colour information. As far as I know that information is only present in the range object, so you have to examine that all the time.

Quote:

Originally Posted by enggrahul78

Below is situation -
My cell contain this text -> " This is testing to Red color. "

I want to populate an array Like , Array(0) = 'testing' and Array(1) = 'color'.

Question about the finally array that you want. If this is the cell content...

This is testing to Red color.

Obviously, Array(0) would be "testing", but about Array(1)... would it be just "Red" with "color" assigned to Array(2) or would Array(1) be "Red color" (both words as a single array element)?

1 Attachment(s)

Thanks p45cal and rothstein but still have another issue....

when i type my reply , it gives error "New posts are scanned for number of URL and forbidded words". I had typed my reply in a word documnet.

Thanks p45cal and rothtein for your help. Can u guys give a look to my word document attached here. Let me ask 1 more question.

On Button1Click ---- I prepared few arrays.
Ob Button2Click ---- i want to use the arrays i created on Button1click. VBA is not allowing me to do so ?? Please help. Refer word doc. for details.

Quote:

Originally Posted by p45cal

Prepare a workbook with some sample strings in merged/unmerged cells, say what range you want to process and what result you're wanting and whether the result should be put back on the sheet or perhaps used by another sub for further processing.

@enggrahul78,

Here is a macro that will directly gather all of the individual unique red words in column A (change the red colored A's below to your actual column letter designation) and place them in a one-based array which I have named RedText in the code below.

Code:

Sub MakeArrayOfUniqueRedTextWords() Dim R As Long, X As Long, Rng As Range, Cell As Range, Arr As Variant, RedText As Variant Set Rng = Range("A1", Cells(Rows.Count, "A").End(xlUp)) Arr = Application.Transpose(Rng.Value) For Each Cell In Rng R = R + 1 For X = 1 To Len(Arr(R)) If Mid(Arr(R), X, 1) = " " Or Cell.Characters(X, 1).Font.Color <> vbRed Then Mid(Arr(R), X) = " " Next Arr(R) = Application.Trim(Arr(R)) Next Arr = Split(Join(Arr)) With CreateObject("Scripting.Dictionary") For X = 0 To UBound(Arr) .Item(Arr(X)) = 1 Next RedText = Application.Transpose(.Keys) End With ' ' At this point in the macro, RedText is a one-based array ' containing all of the individual words that were red color ' End Sub

Code:

Sub Also_unique() for each it in arr if instr(c00,it)=0 then c00 = c00 & " " & it next msgbox c00 sp=split(c00) End sub

Quote:

Originally Posted by snb

Code:

Sub Also_unique() for each it in arr if instr(c00,it)=0 then c00 = c00 & " " & it next msgbox c00 sp=split(c00) End sub

I have found in the past that using a dictionary object to form a unique set of values tends to be faster than testing and concatenating.