Consulting

Results 1 to 17 of 17

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

  1. #1

    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

    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
    Last edited by Aussiebear; 04-18-2019 at 12:15 AM. Reason: Wrapped submitted code in tags

  2. #2
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    479
    Location
    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

  3. #3
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

  4. #4
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    479
    Location
    @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

  5. #5
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

  6. #6
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Okami, if the whole string is red yours ends up with blank cell (also the first and last rows are a bit odd):
    2019-04-18_125057.jpg

    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
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  7. #7
    VBAX Mentor 大灰狼1976's Avatar
    Joined
    Dec 2018
    Location
    SuZhou China
    Posts
    479
    Location
    @p45cal
    Thank you for your correction.
    I noticed my mistake near the end of work yesterday, But your method is better.


    --Okami

  8. #8

    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.
    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 View Post
    Okami, if the whole string is red yours ends up with blank cell (also the first and last rows are a bit odd):
    2019-04-18_125057.jpg

    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

  9. #9
    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

  10. #10
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Quote Originally Posted by enggrahul78 View Post
    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:
    2019-04-20_095858.jpg

    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.
    Last edited by p45cal; 04-20-2019 at 02:12 AM.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  11. #11
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    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.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

  12. #12
    Quote Originally Posted by enggrahul78 View Post
    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)?

  13. #13

    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.
    Attached Files Attached Files

  14. #14
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,844
    Quote Originally Posted by p45cal View Post
    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
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

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

  16. #16
    Knowledge Base Approver VBAX Wizard
    Joined
    Apr 2012
    Posts
    5,635
    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

  17. #17
    Quote Originally Posted by snb View Post
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •