Need to reduce runtime to delete strikethrough characters - excel

Question

Excel workbook consist of 10,000 rows and 25 columns and take 15 mins to complete this process. i need to reduce the runtime to complete this process into less than 1 min. kindly help me out from this situtaion.
For Each cl In rng.SpecialCells(2)
For i = Len(cl.Value) To 1 Step -1
If cl.Characters(i, 1).Font.Strikethrough Then
cl.Characters(i, 1).Delete
End If
Next i
Next cl

Answer 1

Very fast approach via xlRangeValueXMLSpreadsheet Value
Using the relatively unknown xlRangeValueXMLSpreadsheet Value, also referred to as ►.Value(11) solves the question by a very simple string replacement (though the xml string handling can reveal to be very complicated under special conditions).
This approach (quickly tested for 10000 rows) seems to be up to 90 times faster as Tim's valid solution refining the original code, but lasting 14 minutes :-)
Sub RemoveStrThr(rng As Range, Optional colOffset As Long = 1)
'a) Get range data as xml spreadsheet value
Dim xmls As String: xmls = rng.Value(xlRangeValueXMLSpreadsheet) ' //alternatively: xmls = rng.Value(11)
'b) find start position of body
Dim pos As Long: pos = InStr(xmls, "<Worksheet ")
'c) define xml spreadsheet parts and remove <S>-node sections in body
Dim head As String: head = Left(xmls, pos - 1)
Dim body As String: body = Mid(xmls, pos)
'remove strike throughs
Dim results: results = Split(Replace(body, "</S>", "^<S>"), "<S>")
results = Filter(results, "^", False) ' negative filtering of special char "^"
body = Join(results, "")
'd) write cleaned range back
rng.Offset(0, colOffset).Value(11) = head & body
End Sub
Example call
Sub TestRemove()
Application.ScreenUpdating = False
Dim t As Double
t = Timer
RemoveStrThr Sheet1.Range("A2:Z10000"), 27 ' << change to your needs
Debug.Print "done", Format(Timer - t, "0.00 secs")
Application.ScreenUpdating = True
End Sub
Help reference links
Excel XlRangeValueDataType enumeration
Excel Range Value
Addendum (due to #Tim' valuable comment)
Note that if the whole cell content should be struck out then this will not remove the struck-out content: there are no <S> or </S> tags in the element, since the strikethrough is applied via a Style rule (via the xml spreadsheet value head).
To meet this eventuality
"...you could add a second step using something like Application.FindFormat.Font.Strikethrough = True: rng.Replace What:="*", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, SearchFormat:=True: Application.FindFormat.Clear to take care of those cells."

Answer 2

Any use of the Characters collection tends to be kind of slow, so the best you can do (beyond turning off screenupdating) is get some minor improvements by (eg) ignoring cells with no strikethrough, checking for cases where all content is struck through, and batching your calls to Delete.
Sub tester()
Dim t
Range("C1:C3").Copy Range("A1:A999") 'creating some dummy cell values (no/mixed/all ST)
Application.ScreenUpdating = False
t = Timer
RemoveStrikeThrough Range("A1:A999")
Debug.Print "done", Timer - t
End Sub
Sub RemoveStrikeThrough(rng As Range)
Dim cl As Range, hasST, i As Long, pos As Long, st As Boolean
For Each cl In rng.Cells
'only process cells which have any strikethrough style applied
' hasST will be False (no ST), True (all ST) or Null (mixed ST)
hasST = cl.Font.Strikethrough
If TypeName(hasST) = "Boolean" Then
If hasST Then
cl.ClearContents 'all text is struck out, so clear the cell
Else
'Debug.Print "No strikethrough", cl.Address
End If
Else
'mixed - do char by char
For i = Len(cl.Value) To 1 Step -1
If cl.Characters(i, 1).Font.Strikethrough Then
If Not st Then 'new run?
st = True
pos = i
End If
Else
If st Then 'previous run?
cl.Characters(i + 1, pos - i).Delete
st = False
End If
End If
Next i
'remove last strikethough if any
If st Then cl.Characters(1, pos).Delete
st = False 'reset this
End If
Next cl
End Sub