I couldn't let it go. I did a little thinking and came up with the following
code that appears to work.
To use the code, first make a copy of your workbook and work with that copy
to test this. Open the copy of the workbook, press [Alt]+[F11] to open the
VB Editor and choose Insert --> Module. Copy the code below and paste it
into the new module. Close the VB Editor. Select all of the cells you want
to process to remove all Black Text and then run the macro. It even reduces
long strings of spaces to a single space, hope you wanted that.
Sub RemoveBlackText()
Const myBlack = xlAutomatic
Dim strText() As String
Dim intColorIndex() As Integer
Dim groupRange As Range
Dim anyCell As Range
Dim TLC As Long ' text loop counter
Dim newText As String
Dim completedFlag As Boolean
Dim cleanUpLoop As Long
Set groupRange = Selection
For Each anyCell In groupRange
Debug.Print anyCell.Address
ReDim strText(1 To 1)
ReDim intColorIndex(1 To 1)
newText = ""
If Not IsEmpty(anyCell) And _
Trim(anyCell) <> "" Then
For TLC = 1 To Len(anyCell)
'don't even save the black text!
'but must preserve spaces
If anyCell.Characters(TLC, 1).Font.ColorIndex <> myBlack _
Or Mid(anyCell, TLC, 1) = " " Then
strText(UBound(strText)) = Mid(anyCell, TLC, 1)
intColorIndex(UBound(intColorIndex)) = _
anyCell.Characters(TLC, 1).Font.ColorIndex
ReDim Preserve strText(1 To UBound(strText) + 1)
ReDim Preserve intColorIndex(1 To UBound(intColorIndex) + 1)
End If ' anyCell.Text... text
Next ' TLC loop
End If ' end test for empty cells
If UBound(strText) > 1 Then
'had some non-black text
ReDim Preserve strText(1 To UBound(strText) - 1)
ReDim Preserve intColorIndex(1 To UBound(intColorIndex) - 1)
'deal with sequences of blanks
completedFlag = False ' kickstart the loop
Do While Not completedFlag
completedFlag = True ' try to end it
For TLC = 2 To UBound(strText)
If strText(TLC) = " " And _
strText(TLC - 1) = " " Then
For cleanUpLoop = TLC To UBound(strText) - 1
strText(cleanUpLoop) = strText(cleanUpLoop + 1)
intColorIndex(cleanUpLoop) = intColorIndex(cleanUpLoop + 1)
strText(cleanUpLoop + 1) = ""
intColorIndex(cleanUpLoop + 1) = xlAutomatic
completedFlag = False
Next ' cleanUpLoop end
End If ' test for " "
Next ' TLC loop
Loop ' completedFlag loop
For TLC = LBound(strText) To UBound(strText)
newText = newText & strText(TLC)
Next
End If
'put newText back into the cell
anyCell = newText
'now set the colors properly
If Len(newText) > 0 Then
For TLC = LBound(intColorIndex) To UBound(intColorIndex)
anyCell.Characters(TLC, 1).Font.ColorIndex = intColorIndex(TLC)
Next
End If
Next ' anyCell loop
End Sub
"ILMER57" wrote:
> Many thanks for your answer - I was afraid that there would not be a supplied
> function to do this. You are right, I have hundreds of cells like this and
> they are altered as the spread sheet develops. I suppose one option could be
> to copy the cells into WORD and then use the search and replace options in
> that program but that gets messy. Is the macro option out of the question
> and if not can the question be pursued here or should it be asked in another
> forum?
>
>
> "JLatham" wrote:
>
> > Not based on color with worksheet functions. It could be done with VBA code
> > (a macro) but it would be ugly code to write.
> >
> > I'm guessing there's more than on cell involved? Otherwise it would be just
> > as easy to just manually edit the darned thing.
> >
> > "ILMER57" wrote:
> >
> > > I have a cell in excel containing a string of text with some characters in
> > > black some in green and some in red. I want to remove all the black text
> > > leaving only the red and green. Can this be done?
|
Similar Threads
