Excel VBA - How to remove text of a certain color from every cell in a column

Question

Edit: Now its working much better but the code starts deleting non-black text from other columns as well?_? the code works for other worksheets so I'm not sure why it only doesn't work for this one... :"( pls help

I have an excel sheet with text that has multiple colors in the same cell eg blue and black words in the same cell. I want to remove all the blue words. I wrote a loop that loops through the cells and every character in the cells in the entire column and writes the black words back to each cell. However it takes a really long time so its not very feasible. Also I tried using arrays but I'm not sure how to store the format alongside the value into the array:"( Thanks!

Sub deletecommentsRight_New()

    Dim lrow As Long
    Dim textOut As String
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    lrow = LastRow()
    Range("M1:M" & lrow).Select
    
    For Each Cell In Selection
        textOut = ""
        For i = 1 To Len(Cell)
            If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
                textOut = textOut & Mid(Cell, i, 1)
            End If
        Next
        Cell.Value = textOut
        Cell.Font.ColorIndex = 1
    Next Cell
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Public Function LastRow() As Long
'Finds the last non-blank cell on a sheet/range.

Dim lrow As Long
Dim lCol As Long
    
    lrow = Cells.Find(What:="*", _
                    After:=Range("A1"), _
                    LookAt:=xlPart, _
                    LookIn:=xlFormulas, _
                    SearchOrder:=xlByRows, _
                    SearchDirection:=xlPrevious, _
                    MatchCase:=False).Row
    
    LastRow = lrow

End Function

Answer 1

You are doing this for over a million cells, most of them are empty. If you start by checking that the cell is not empty, you might heavily improve the performance.

Answer 2

Building on the suggestions provided, here is the modified code. Since the original code worked on selection, an option to ask the user to select a range is opted than defining fixed ranges.

Sub deletecomments()

    Dim textOut As String
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    '----------------------------
    Dim myrange As Range
    ThisWorkbook.Sheets("Sheet1").Activate   'Change Workbook and Sheet name accordingly
    Set myrange = Application.InputBox(Title:="Range Selector", Prompt:="Please select your Range.", Type:=8)
    '--------------------------

    For Each Cell In myrange  'Replace selection with myRange
        textOut = ""
        For i = 1 To Len(Cell)
            If (((Cell.Characters(i, 1).Font.ColorIndex = 1) Or (Cell.Characters(i, 1).Font.ColorIndex = -4105)) And Not (Cell.Characters(i, 1).Font.Strikethrough)) Then
                textOut = textOut & Mid(Cell, i, 1)
            End If
        Next
        Cell.value = textOut
        Cell.Font.ColorIndex = 1
    Next Cell
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Answer 3

First of all, you should always use Option Explicit at the top of your modules so that it forces you to declare all variables properly.

There is no need to loop through an entire column. Only loop through cells that actually have values. For that we can use the Worksheet.UsedRange property and do an Intersect with the desired range.

Also code should be able to ignore errors and numbers since you are only interested in texts.

Also, there is no need to read the cell value multiple times so best is to read them just once using an array. A With construct can help in reading the cell font colors easily.

Here is what I came up with - kept the original method name:

Option Explicit

Public Sub DeleteComments(ByVal rng As Range)
    Dim tempRng As Range
    Dim tempArea As Range
    
    Set tempRng = GetUsedRange(rng)
    If tempRng Is Nothing Then Exit Sub
    
    'Store app state and turn off some features
    Dim scrUpdate As Boolean: scrUpdate = Application.ScreenUpdating
    Dim calcMode As XlCalculation: calcMode = Application.Calculation
    Dim evEnabled As Boolean: evEnabled = Application.EnableEvents
    With Application
        If .ScreenUpdating Then .ScreenUpdating = False
        If calcMode <> xlCalculationManual Then .Calculation = xlCalculationManual
        If .EnableEvents Then .EnableEvents = False
    End With
    
    'Loop through all areas. Check/update only relevant values
    For Each tempArea In tempRng.Areas
        If tempArea.Count = 1 Then
            UpdateCell tempArea, tempArea.Value2
        Else
            Dim arr() As Variant: arr = tempArea.Value2 'Read whole range into array
            Dim rowsCount As Long: rowsCount = tempArea.Rows.Count
            Dim i As Long: i = 1
            Dim j As Long: j = 1
            Dim v As Variant
            
            'For Each... loop is faster than using 2 For... Next loops on a 2D array
            For Each v In arr 'Column-major order
                If VarType(v) = vbString Then 'Only check strings - ignore numbers and errors
                    If Len(v) > 0 Then UpdateCell tempArea.Cells(i, j), v
                End If
                i = i + 1
                If i > rowsCount Then 'Switch to the next column
                    j = j + 1
                    i = 1
                End If
            Next v
        End If
    Next tempArea

    'Restore app state
    With Application
        If scrUpdate Then .ScreenUpdating = True
        If calcMode <> xlCalculationManual Then .Calculation = calcMode
        If evEnabled Then .EnableEvents = True
    End With
End Sub

Private Function GetUsedRange(ByVal rng As Range) As Range
    If rng Is Nothing Then Exit Function
    On Error Resume Next
    Set GetUsedRange = Intersect(rng, rng.Worksheet.UsedRange)
    On Error GoTo 0
End Function

Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
    Dim textOut As String
    Dim charExcluded As Boolean
    Dim i As Long

    For i = 1 To Len(value)
        With cell.Characters(i, 1).Font
            If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
                textOut = textOut & Mid$(value, i, 1)
            Else
                charExcluded = True
            End If
        End With
    Next i
    If charExcluded Then cell.Value2 = textOut
    If IsNull(cell.Font.ColorIndex) Then
        cell.Font.ColorIndex = 1
    ElseIf cell.Font.ColorIndex <> 1 Then
        cell.Font.ColorIndex = 1
    End If
End Function

As you can see, I've split the code in a few auxiliary functions so that is easier to maintain.

To use it just call it on the desired range. For example:

DeleteComments Selection 'if you already have a selected range
'Or
DeleteComments Range("M:M") 'as in your original post

An added benefit is that this code works regardless if your desired range is a column, a row, multiple columns/rows or even multi-area ranges. Gives you a lot of flexibility and is as fast as you could make it.

Edit #1

The UpdateCell function could be faster if we only check cells with mixed colors:

Private Function UpdateCell(ByVal cell As Range, ByVal value As Variant)
    Dim textOut As String
    Dim charExcluded As Boolean
    Dim i As Long

    If IsNull(cell.Font.ColorIndex) Then
        For i = 1 To Len(value)
            With cell.Characters(i, 1).Font
                If (.ColorIndex = 1 Or .ColorIndex = -4105) And Not .Strikethrough Then
                    textOut = textOut & Mid$(value, i, 1)
                Else
                    charExcluded = True
                End If
            End With
        Next i
        If charExcluded Then cell.Value2 = textOut
        cell.Font.ColorIndex = 1
    ElseIf cell.Font.ColorIndex <> 1 Then
        cell.Value2 = Empty
        cell.Font.ColorIndex = 1
    End If
End Function