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

A

alishern

New Member
Joined
Dec 9, 2017
Messages
29
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
1695325709014.png


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

Error:
1695325777194.png



VBA Code: 
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
 
Sort by date Sort by votes
kevin9999 said:
the Range.Characters property has a limit of 255 characters.
Click to expand...
I agree with this, but I think the limit is 256 characters.
Try this on a cell with more than 256 characters:
VBA Code: 
 Debug.Print ActiveCell.Characters(1, 256).Text  '<-- works
 Debug.Print ActiveCell.Characters(1, 257).Text  '<-- error

@alishern
As kevin9999, I also can't find a way around this limitation.
If you want, I could write a code to do the task but skips the cells with more than 256 characters.
 
Upvote 0

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
I end up with an UDF solution. It also works for subroutine solution
First, I tried to collect position of characters those need to be removed first
Next, replace characters with special character (@)
Finally, replace "@" with ""
In B2, to get A2 value, remove strikethrough:
=ClearS(A2)
drag down

Solutions_TEST_CODE.xlsm

drive.google.com drive.google.com
VBA Code: 
Option Explicit
Function ClearS(ByVal rng As Range)
Dim i&, st As String, dic As Object, key
Set dic = CreateObject("Scripting.Dictionary")
st = rng.Value
For i = 1 To Len(rng)
    With rng.Characters(i, 1).Font
        If .Strikethrough Or .Color = vbRed Then
            dic.Add i, ""
        End If
    End With
Next
For Each key In dic.keys
    st = Left(st, key - 1) & "@" & Mid(st, key + 1, len(rng))
Next
Set dic = Nothing
ClearS = WorksheetFunction.Substitute(st, "@", "")
End Function
 
Upvote 0
Akuini said:
I agree with this, but I think the limit is 256 characters.
Try this on a cell with more than 256 characters:
VBA Code: 
 Debug.Print ActiveCell.Characters(1, 256).Text  '<-- works
 Debug.Print ActiveCell.Characters(1, 257).Text  '<-- error

@alishern
As kevin9999, I also can't find a way around this limitation.
If you want, I could write a code to do the task but skips the cells with more than 256 characters.
Click to expand...
Akuini,

Based on the conversation that has built around the solution, I shifted my focus on fixing the number section of the data sample (rows 10 through 36 in 'Solutions_TEST_CODE.xlsm' file). So, if you can, please write a code to handle that range only. If you don't mind, please give me two options 1. Posting the result in a separate column; 2. Perform the editing on the same column.

Akuini & Kevin - I thank you greatly for your effective support in the community!
 
Upvote 0
alishern said:
Akuini,

Based on the conversation that has built around the solution, I shifted my focus on fixing the number section of the data sample (rows 10 through 36 in 'Solutions_TEST_CODE.xlsm' file). So, if you can, please write a code to handle that range only. If you don't mind, please give me two options 1. Posting the result in a separate column; 2. Perform the editing on the same column.

Akuini & Kevin - I thank you greatly for your effective support in the community!
Click to expand...
I think I can figure out a way to handle cells with more than 256 characters. I'll post the code once it finished. However, as I mentioned earlier, 'because the code will loop through each character in column A, it will be slow with large text.' I tested it with 10,000 characters of data, and it took approximately 9 seconds.
How large is your actual dataset in terms of the number of characters?

Did you try the solution by @bebo021999 in post #22?
 
Upvote 0
Here, try this:
VBA Code: 
Sub Clear_3()
Dim c As Range, i As Long, j As Long, k As Long, h As Long, p As Long, n As Long
Dim s, tx As String, bx As String
Dim t As Double
t = Timer
Application.ScreenUpdating = False
    n = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & n).Copy Range("B1")
    ReDim va(1 To n, 1 To 1)
   
    For Each c In Range("B2:B" & n)
        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, 1) = bx
    Next
    Range("B2").Resize(UBound(va, 1), 1) = va
   
Application.ScreenUpdating = True
Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"

End Sub

clear red font.jpg
 
Upvote 0
Akuini said:
Here, try this:
VBA Code: 
Sub Clear_3()
Dim c As Range, i As Long, j As Long, k As Long, h As Long, p As Long, n As Long
Dim s, tx As String, bx As String
Dim t As Double
t = Timer
Application.ScreenUpdating = False
    n = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & n).Copy Range("B1")
    ReDim va(1 To n, 1 To 1)
  
    For Each c In Range("B2:B" & n)
        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, 1) = bx
    Next
    Range("B2").Resize(UBound(va, 1), 1) = va
  
Application.ScreenUpdating = True
Debug.Print "Completion time:  " & Format(Timer - t, "0.00") & " seconds"

End Sub

View attachment 99867
Click to expand...
Akuini,

The code worked great. In my file, I work with an excel table. To imitate my work file, I updated the excel file on the OneDrive by inserting a table sheet where I have an excel table 'Table1'. I will need to apply the cleaning to columns 'WORKLOAD_DRIVERS' and 'DATA_INPUT' ( Range("Table1[[WORKLOAD_DRIVERS]:[DATA_INPUT]]") )

Can you please adjust your code to apply the cleaning right on the source columns without posting the result on a separate column?

Thanks again!
 
Upvote 0
Akuini said:
I think I can figure out a way to handle cells with more than 256 characters. I'll post the code once it finished. However, as I mentioned earlier, 'because the code will loop through each character in column A, it will be slow with large text.' I tested it with 10,000 characters of data, and it took approximately 9 seconds.
How large is your actual dataset in terms of the number of characters?

Did you try the solution by @bebo021999 in post #22?
Click to expand...
I tried the solution from bebo021999, but i will not be utilizing a function in my file, so it won't serve my purpose.

​

 
Upvote 0
alishern said:
Akuini,

The code worked great. In my file, I work with an excel table. To imitate my work file, I updated the excel file on the OneDrive by inserting a table sheet where I have an excel table 'Table1'. I will need to apply the cleaning to columns 'WORKLOAD_DRIVERS' and 'DATA_INPUT' ( Range("Table1[[WORKLOAD_DRIVERS]:[DATA_INPUT]]") )

Can you please adjust your code to apply the cleaning right on the source columns without posting the result on a separate column?

Thanks again!
Click to expand...
Can you show us the table?
 
Upvote 0
Try this:
VBA Code: 
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
 
Upvote 1
Solution
Akuini said:
Try this:
VBA Code: 
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
Click to expand...
Akuini,

Thanks for the solution. It works much better than expected. I added a separate code to remove semicolons (below) and your code to call it as a last step.

1696943471800.png


VBA Code: 
Sub RemoveSemicols()
'
' RemoveSemicol
Dim DataCol As Range
Set DataCol = Range("TDP_2[DATA_INPUT]")

    DataCol.Replace What:=";", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
                
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Assistance with excel macro
Replies
3
Views
259
dreid1011
dreid1011
R
  • Solved
VBA - Find Replace on selected cells
Replies
3
Views
408
rsulliva
R
M
  • Solved
VBA to swap cell values, but enter the swapped value in cell below.
2
Replies
10
Views
729
myall_blues
myall_blues
H
  • Solved
VBA Font Conditional Formatting based on cell value change - but it doesn't trigger
Replies
3
Views
91
hcgood
H
M
  • Solved
Stack comments with VBA instead of clear and overwrite
Replies
8
Views
352
MeaclH
M

Forum statistics

Threads
1,224,823
Messages
6,181,183
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top