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]

Try this:

Sub Clear_4()
Dim i As Long, j As Long, k As Long, h As Long, p As Long, n As Long, q As Long
Dim s, tx As String, bx As String
Dim t As Double
Dim c As Range, f As Range
t = Timer
Application.ScreenUpdating = False
    Set f = Range("Table1[[WORKLOAD_DRIVERS]:[DATA_INPUT]]")
    ReDim va(1 To f.Rows.Count, 1 To f.Columns.Count)
    
    For q = 1 To 2
        p = 0
        For Each c In f.Columns(q).Cells
            j = 0
            tx = "0"
            p = p + 1
            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
                        tx = tx & "," & j & "," & i - 1
                            j = 0
                        End If
                    End If
                Next i
                    If j > 0 Then
                        tx = tx & "," & j & "," & i - 1
                    End If
                tx = tx & "," & Len(c) + 1
            End With
            
            s = Split(tx, ",")
            bx = ""
            For i = 0 To UBound(s) Step 2
                h = (s(i)) + 1
                If h < s(i + 1) Then
                    bx = bx & Mid(c.Value, h, s(i + 1) - h)
                End If
            Next
                va(p, q) = bx
        Next
    Next
    
    f = va
        With f.Font
            .Strikethrough = False
            .ColorIndex = xlAutomatic
        End With
Application.ScreenUpdating = True

Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"
End Sub

 

[Akuini]

Akuini,

This case is considered as resolved, but if I were to expand the range from currently 2 columns to 5 columns, where in the code do i make the edit?

Change this part:

 For q = 1 To 2

to this:

 For q = 1 To f.Columns.Count

It will adjust the code to match the number of columns in the range you specify in this part:

Set f = Range("Table1[[WORKLOAD_DRIVERS]:[DATA_INPUT]]")

 

[alishern]

Example 1 attachment

 

[Akuini]

I have a large excel file that I receive from the users with comments.

About how many rows is it?
It would be easier & faster if you delete texts with strikethroughs & text in red in Word. So, copy paste the table to Word.
Open replace dialog box.
Click Format > Font > Strikethrough > OK > Replace All
Click No Formatting > Format > Font > Font color > Red color > OK > Replace All
Copy back table to Excel.

 

[alishern]

About how many rows is it?
It would be easier & faster if you delete texts with strikethroughs & text in red in Word. So, copy paste the table to Word.
Open replace dialog box.
Click Format > Font > Strikethrough > OK > Replace All
Click No Formatting > Format > Font > Font color > Red color > OK > Replace All
Copy back table to Excel.

It is a large file and i want to do it in excel. This will be a repetitive effort and i need to automate it.

 

[Akuini]

It is a large file and i want to do it in excel. This will be a repetitive effort and i need to automate it.

Sorry, I don't know how to do it in Excel.
Hopefully somebody will be able to help.

 

[kevin9999]

Please try the following on a copy of your worksheet:

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

 

[kevin9999]

Amended code to include semicolons that are neither red nor strikethrough.

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

 

[alishern]

Amended code to include semicolons that are neither red nor strikethrough.

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

Kevin,

First off, thank you. Here is what I am getting: - Column C is my comments. Looks like it works fine on the numbers, but for mix strings it is not showing the expected result.