VBA to Clear texts with Strikethroughs, Red fonts and semicolons in cells (selection)

[alishern]

Hi,

I have a large excel file that I receive from the users with comments. The comments include texts with strikethroughs in red fonts that need to be removed - basically, the text with strikethroughs (and sometimes in red fonts) are obsolete and need to be removed. I need to be able to remove the texts with strikethroughs inside each cell in a selected range. Here are a few examples:

Example 1 - the result does not need to retain the original formatting (blue font in this case)
View attachment 99109

Example 2

Dug up a few codes (see below), but it throws this error. As usual, thank you in advance.

Error:

Sub DelStrikethroughText()
  
   Application.ScreenUpdating = False
    
   'Deletes strikethrough text in all selected cells
   Dim Cell    As Range
  
   For Each Cell In Selection
      DelStrikethroughs Cell
   Next Cell
  
   'remove removeSemiCol texts
   Selection.replace What:=";", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2

        
   Application.ScreenUpdating = True
  
End Sub

Sub DelStrikethroughs(Cell As Range)
   'deletes all strikethrough text in the Cell
   Dim NewText    As String
   Dim iCh        As Integer
   For iCh = 1 To Len(Cell)
      With Cell.Characters(iCh, 1)
         If .Font.Strikethrough = False Then
            NewText = NewText & .Text
         End If
      End With
   Next iCh
   Cell.Value = NewText
   Cell.Characters.Font.Strikethrough = False
End Sub

 

[Akuini]

Here's my attempt:
However, because the code will loop through each character in col A, it will be slow on large text.

Sub Clear_1()
Dim c As Range, i As Long, j As Long
Dim t As Double
t = Timer
    Application.ScreenUpdating = False
    
    For Each c In Range("A2", Cells(Rows.Count, "A").End(xlUp))
        j = 0
        With c
            For i = 1 To Len(c)
                If .Characters(i, 1).Font.Color = vbRed Then
                    If j = 0 Then j = i
                ElseIf .Characters(i, 1).Font.Strikethrough = True Then
                    If j = 0 Then j = i
                Else
                    If j > 0 Then
                        .Characters(j, i - j).Text = WorksheetFunction.Rept(";", i - j)
                        j = 0
                    End If
                End If
            Next i
                If j > 0 Then
                    .Characters(j, i - j).Text = WorksheetFunction.Rept(";", i - j)
                End If
        End With
    Next
    
        Range("A:A").Replace What:=";", Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

        With Range("A:A").Font
            .Strikethrough = False
            .ColorIndex = xlAutomatic
        End With

    Application.ScreenUpdating = True
Debug.Print n & " :  " & Format(Timer - t, "0.00") & " seconds"

End Sub

 

[kevin9999]

Updated with 2 options - move the cleaned values to column B, or clean in situ.

Option Explicit
Sub Clear_Red_Strikethrough_Semicolon_V2()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")       '<-- *** Change to actual sheet name ***
    Dim c As Range, i As Long
    
    ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp)).Copy ws.Range("B2")
    For Each c In ws.Range("B2", ws.Cells(Rows.Count, "B").End(xlUp))
        For i = Len(c.Text) To 1 Step -1
            If c.Characters(i, 1).Font.Color = vbRed Or _
                c.Characters.Font.Strikethrough = True Or _
                Mid(c, i, 1) = ";" Then
                If i >= 1 And i < Len(c) Then
                    c.Characters(i, 1).Text = ""
                Else
                    c = ""
                End If
            End If
        Next i
    Next c
    Application.ScreenUpdating = True
End Sub

Option Explicit
Sub Clear_RSS_In_Situ_V2()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")       '<-- *** Change to actual sheet name ***
    Dim c As Range, i As Long
    
    For Each c In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
        For i = Len(c.Text) To 1 Step -1
            If c.Characters(i, 1).Font.Color = vbRed Or _
                c.Characters.Font.Strikethrough = True Or _
                Mid(c, i, 1) = ";" Then
                If i >= 1 And i < Len(c) Then
                    c.Characters(i, 1).Text = ""
                Else
                    c = ""
                End If
            End If
        Next i
    Next c
    Application.ScreenUpdating = True
End Sub

 

[alishern]

Ignore the code in post #9. I'll need to revise it, leave it with me.

Ok, sounds good.

 

[kevin9999]

Ok, sounds good.

My revised code is in post # 12.

 

[alishern]

Option 2: clean in site

Option Explicit
Sub Clear_RSS_In_Situ_V2()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")       '<-- *** Change to actual sheet name ***
    Dim c As Range, i As Long
   
    For Each c In ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
        For i = Len(c.Text) To 1 Step -1
            If c.Characters(i, 1).Font.Color = vbRed Or _
                c.Characters.Font.Strikethrough = True Or _
                Mid(c, i, 1) = ";" Then
                If i >= 1 And i < Len(c) Then
                    c.Characters(i, 1).Text = ""
                Else
                    c = ""
                End If
            End If
        Next i
    Next c
    Application.ScreenUpdating = True
End Sub

Kevin,

Thanks for the response. I used option B. It fixes the most but it is not fixing this scenario

 

[Akuini]

@alishern
Did you try my code in post #11?

 

[alishern]

@alishern
Did you try my code in post #11?

It throws error in this section

Also, the result is a bit funky

 

[Akuini]

It throws error in this section

Could you please upload a sample workbook (without sensitive data) to a file-sharing site like Dropbox.com or Google Drive, and then share the link here? Also, ensure that the link is accessible to anyone.

 

[alishern]

Could you please upload a sample workbook (without sensitive data) to a file-sharing site like Dropbox.com or Google Drive, and then share the link here? Also, ensure that the link is accessible to anyone.

As requested, please see link to OneDrive with the sample file:

Solutions_TEST_CODE.xlsm

Microsoft Excel Workbook

1drv.ms

Thanks,

 

[kevin9999]

Kevin,

Thanks for the response. I used option B. It fixes the most but it is not fixing this scenario

View attachment 99713

Thanks for the response. I used option B. It fixes the most but it is not fixing this scenario

It seems that, based on anecdotal chatter I've seen around the place, the Range.Characters property has a limit of 255 characters. I tested this and it seems it could be true. When I first ran the code, I got the same result as you. The character count in cell A4 is 349.

Then I reduced the character count in cell A4 to less than 255 characters, I ran the code again, it removed the red text from cell A4. Unfortunately, I can't find a way around this limitation. Sorry, but I hope someone else will be able to help you further with this issue.