Extracting just words with color letter

[mariela]

Hi, two days I'm trying to find solution to this problem:

I have table in Excel (2003, WinXP) with text
every cell contains a few words. Just one of the words have red letter.
I need to extract words containg the red letter and sort them by abc.
Sorting is not the problem but extracting.

In Microsoft forums one smart guy help me to extract the red letter with this code:

=ColorWord(A1,3)

to extract the red letters from cell A1.

HTH,
Bernie
MS Excel MVP


Function ColorWord(myCell As Range, iColor As Integer)
Dim i As Integer
ColorWord = ""
With myCell
For i = 1 To Len(myCell.Text)
With .Characters(i, 1).Font
If .ColorIndex = iColor Then
ColorWord = ColorWord & Mid(myCell.Text, i, 1)
End If
End With
Next i
End With
End Function


I tried to changed it and nothing worked.
What I need to be chaged here is - range from A1:D5000
and extracting the whole word.

Thanks in advance,

Mariela

 

[Richie(UK)]

Hi Mariela,

Welcome to the board.

OK, only briefly tested but how about:

Function ColorWord(myCell As Range, iColor As Integer)
'original by Bernie - MS Excel MVP
    Dim i As Integer, varText As Variant, lWord As Long, lLetter As Long
    ColorWord = ""
    varText = XL97Split(myCell.Text, " ")
    With myCell
        For i = 1 To Len(myCell.Text)
            With .Characters(i, 1).Font
                If .ColorIndex = iColor Then
                    lLetter = 0
                    For lWord = LBound(varText) To UBound(varText)
                        lLetter = lLetter + Len(varText(lWord)) + 1
                        If i < lLetter Then
                            ColorWord = ColorWord & varText(lWord) & ", "
                            Exit For
                        End If
                    Next lWord
                End If
            End With
        Next i
    End With
    If Len(ColorWord) > 0 Then ColorWord = Left(ColorWord, Len(ColorWord) - 2)
End Function

Function XL97Split(ByVal StrToParse As String, Delimiter As String) As Variant
    Dim StrLen As Integer, OurPos As Integer
    Dim OurArray() As String
    Dim Counter As Integer
    Dim OurChar As String
    ReDim OurArray(0 To 0)
    StrLen = Len(StrToParse)
    While OurPos < StrLen
        OurPos = OurPos + 1
        OurChar = Mid(StrToParse, OurPos, 1)
        If OurChar = Delimiter Then
            Counter = Counter + 1
            ReDim Preserve OurArray(0 To Counter)
        Else
            OurArray(Counter) = OurArray(Counter) & OurChar
        End If
    Wend
    XL97Split = OurArray
End Function

If you have Excel 2003 then you won't need the second function, just change the line - varText = XL97Split(myCell.Text, " ") so that it reads - varText = Split(myCell.Text, " ").

Use the UDF as before, eg =ColorWord(A1,3)

HTH

 

[R_Stephens]

Hi there,

Not sure if this is exactly what you are wanting. It assumes your range of cells with text is on Sheet1, and you want the list of extracted words putting on Sheet2. It also assumes that the Red letter is at the beginning of each word, if not let me know and I'll alter the code (kept it simple to start)

Dim myrange As Range
Dim mycolour As Integer
Dim x As Integer
Dim i As Integer
Dim wordend As Integer
Dim mystring As String
Set myrange = Sheets("Sheet1").Range("A1:D5000")
mycolour = 3
x = 1
For Each c In myrange
For i = 1 To Len(c.Text)
        If c.Characters(i, 1).Font.ColorIndex = mycolour Then
            wordend = InStr(i, c.Text, " ", vbTextCompare)
                If wordend = 0 Then
                    mystring = Mid(c.Text, i)
                Else
                    mystring = Mid(c.Text, i, wordend - i)
                End If
        Sheets("Sheet2").Cells(x, 1).Value = mystring
        x = x + 1
        End If
Next i
Next c

Hope this helps

Richard

 

[mariela]

Richie - Thank you it's working and extracting the whole word. Is there a way to save red letter? After extracting all letters in the word become black.

R_Stephens - your first assumption was right - cells with text are in Sheet1, I don't mind if the extracting words will be in Sheet1 ot Sheet2 as long as I get the result. Unfortunately red letter is in different position in the words. It is religious text and if I'm right it's some sort of kabbala text. I mean that red letter symbolize some number which will give the answer of some question. This is my assuption. And if there is a chance to save red letter after extracting I'll be very happy

Thanks guys anyway -

Mariela

 

[R_Stephens]

Hi there,

I have made a few alterations, see if this does what you want.
Note, Delete everything from Sheet2 before re-running the macro, else you will lose your red letters

Dim myrange As Range
Dim mycolour As Integer
Dim x As Integer
Dim i As Integer
Dim wordend As Integer
Dim wordstart As Integer
Dim redletter As Integer
Dim mystring As String
Set myrange = Sheets("Sheet1").Range("A1:D5000")
mycolour = 3
x = 1
For Each c In myrange
For i = 1 To Len(c.Text)
        If c.Characters(i, 1).Font.ColorIndex = mycolour Then
            wordend = InStr(i, c.Text, " ", vbTextCompare)
            wordstart = InStrRev(c.Text, " ", i, vbTextCompare) + 1
            If wordstart = 0 Then wordstart = 1
                If wordend = 0 Then
                    mystring = Mid(c.Text, wordstart)
                Else
                    mystring = Mid(c.Text, wordstart, wordend - wordstart)
                End If
        redletter = i - wordstart + 1
        Sheets("Sheet2").Cells(x, 1).Value = mystring
        Sheets("Sheet2").Cells(x, 1).Characters(redletter, 1).Font.ColorIndex = 3
        x = x + 1
        End If
Next i
Next c

Hope this helps

Richard

 

[mariela]

Richard,

I'm receiving 'Runtime error 5. Invalid procedure call or argument'

After checking Sheet2 - ther is a result - as I wanted to be!!!

ray:

Thanks for your help!!!!!


Mariela

 

[R_Stephens]

Mariela,

Is it highlighting any line in particular if you click on Debug when you get the Run Time error?

Richard

 

[mariela]

yes in this one:

mystring = Mid(c.Text, wordstart, wordend - wordstart)



By the way some of the words after extracting get all their letters in red.

Mariela

 

[R_Stephens]

Hi

Tried revising the code, try this one:

Dim myrange As Range
Dim mycolour As Integer
Dim x As Integer
Dim i As Integer
Dim wordend As Integer
Dim wordstart As Integer
Dim wordlen As Integer
Dim redletter As Integer
Dim mystring As String
Set myrange = Sheets("Sheet1").Range("A1:D5000")
mycolour = 3
x = 1
For Each c In myrange
For i = 1 To Len(c.Text)
        If c.Characters(i, 1).Font.ColorIndex = mycolour Then
            wordend = InStr(i, c.Text, " ", vbTextCompare)
            wordstart = InStrRev(c.Text, " ", i, vbTextCompare) + 1
            If wordstart = 0 Then wordstart = 1
                If wordend = 0 Then
                    mystring = Mid(c.Text, wordstart)
                Else
                    wordlen = wordend - wordstart
                    If wordlen < 0 Then wordlen = 1
                    mystring = Mid(c.Text, wordstart, wordend - wordstart)
                End If
        redletter = i - wordstart + 1
        Sheets("Sheet2").Cells(x, 1).Value = mystring
        Sheets("Sheet2").Cells(x, 1).Font.ColorIndex = 1
        Sheets("Sheet2").Cells(x, 1).Characters(redletter, 1).Font.ColorIndex = 3
        x = x + 1
        End If
Next i
Next c

It seems to be working fine on my computer with test data.

Richard

 

[mariela]

Received the same error on :

mystring = Mid(c.Text, wordstart, wordend - wordstart)


but result is perfect!


Mariela