Extracting just words with color letter

mariela

New Member
Joined
Jan 19, 2005
Messages
9
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
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Richie(UK)

MrExcel MVP
Joined
May 17, 2002
Messages
3,329
Hi Mariela,

Welcome to the board.

OK, only briefly tested but how about:
Code:
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

Board Regular
Joined
Dec 23, 2004
Messages
143
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)

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

New Member
Joined
Jan 19, 2005
Messages
9
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 - (y)

Mariela
 

R_Stephens

Board Regular
Joined
Dec 23, 2004
Messages
143

ADVERTISEMENT

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


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

New Member
Joined
Jan 19, 2005
Messages
9
Richard,

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

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

:pray:

Thanks for your help!!!!!


Mariela
 

R_Stephens

Board Regular
Joined
Dec 23, 2004
Messages
143

ADVERTISEMENT

Mariela,

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

Richard
 

mariela

New Member
Joined
Jan 19, 2005
Messages
9
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

Board Regular
Joined
Dec 23, 2004
Messages
143
Hi

Tried revising the code, try this one:

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

New Member
Joined
Jan 19, 2005
Messages
9
Received the same error on :

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


but result is perfect!


Mariela
 

Forum statistics

Threads
1,147,688
Messages
5,742,626
Members
423,744
Latest member
bkirtland

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top