Can I delete ONLY black text from within cells?

[MsCynic]

Hi guys, I have a table of 280 rows with around 12 columns.

I have marked certain parts of text in one column with different colours to represent products of particular interest. There are five colours used and I set these in MS Word.

I'd now like to remove all text that is not one of these colours while leaving the coloured text in the cells.

Can it be done? I did find a VBA someone had written for a poster on a different forum but with no experience in VBA I have been unable to make it work for me.

Thanks in advance for advice,
Jo

PS someone may have a better solution to offer so here's the full brief:
I am sifting through 280 company names who have expressed interest in a variety of tourism products, around 30 different items. I am representing 12 items and want to:
a) filter out the irrelevant interests for companies I needn't see
b) Count the number of times each of my items is mentioned
c) ensure that each of my 12 items gets fairly included in meeting requests.

 

[p45cal]

Could you put a version of your workbook with sample data somewhere on the interweb and link to it here? (You say you've set the colours in MSWord, so there might any amount of formatting to look for/ignore.)

 

[MsCynic]

Yep, this is the column in question: https://www.cubby.com/p/_512765ad71d24d589343ccfddc0928a0/interest+only.xlsx

 

[p45cal]

This took longer than I thought it would, both in developing and code execution time. With your long strings in the cells it take 2 to 3 seconds per cell here, so nearly 300 cells is going to take some 12 minutes.
At the moment, it works on the selected cells, so select a few cells in column A before running blah. Later, we can automate which cells it should act on.
At the moment, it puts the results in the cell immediately to the right, again this can be changed to just put the results in the same cell; in the code there are two lines:

With cll.Offset(, 1)
' With cll

The second is commented out with the apostrophe. Move the apostrophe to the start of the first of these two lines to have the results in the same cell.

Sub blah()
'Range("A2:A279").Select
Dim TextColour()
For Each cll In Selection.Cells
    ReDim TextColour(1 To 2, 1 To 1)
    x = 0
    For i = 1 To Len(cll.Value)
        myLength = 1
        myColour = cll.Characters(i, 1).Font.Color
        LengthAndColour cll, i, myColour, myLength
        If myColour <> 0 Then
            If x = 0 Then
                x = 1
            Else
                x = UBound(TextColour, 2) + 1
                ReDim Preserve TextColour(1 To 2, 1 To x)
            End If
            TextColour(1, x) = Mid(cll.Value, i, myLength)
            TextColour(2, x) = myColour
        End If
        i = i + myLength - 1
    Next i
    newStr = Join(Application.Index(TextColour, 1), ",")
    With cll.Offset(, 1)
    ' With cll
        .Clear
        .Value = newStr
        start = 1
        For i = LBound(TextColour, 2) To UBound(TextColour, 2)
            .Characters(start, Len(TextColour(1, i))).Font.Color = TextColour(2, i)
            start = start + Len(TextColour(1, i)) + 1
        Next i
    End With
Next cll
End Sub
Sub LengthAndColour(theCell, start, colour, length)
L = Len(theCell.Value)
Do Until (theCell.Characters(start + length, 1).Font.Color <> colour) Or ((start + length) > L)
    length = length + 1
Loop
End Sub

Note what it does with Cycling in A11.

 

[MsCynic]

Wow, you've gone to so much trouble for me, thanks so much.
Um, how would I run this? I opened up VBA but coudlnt' see anwhere to paste the code - woudl you mind guiding me a bit more on the execution?

 

[p45cal]

see:Excelguru Help Site - Adding VBA Code For The First Time User

 

[MsCynic]

That's a really great tutorial, thanks for pointing it out. Every other site I found when searching for VBA help just confused me more.
The macro is running now - as you say it will take a while. Thanks again for your help.