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

[enggrahul78]

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


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

[大灰狼1976]

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

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

[snb]

Same result, less 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

[大灰狼1976]

@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

[snb]

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

[p45cal]

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

My quick and dirty offering with minimal alterations to the original function:
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

[大灰狼1976]

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


--Okami

[enggrahul78]

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

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




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

My quick and dirty offering with minimal alterations to the original function:
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

[rothstein]

Here is another function to try...

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

[p45cal]

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:
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.

[p45cal]

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:
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.

[rothstein]

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)?

[enggrahul78]

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.

[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.

[rothstein]

@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.



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

[snb]

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

[rothstein]

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.