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