Excel vba execution time exponentially related to cell content length

Question

I'm using vba for checking a spreadsheet for strikethrough text. As

ActiveCell.Font.Strikethrough 

only detects strikethrough in the entire cell, I used following code that counts individual characters with strikethrough.

Dim iCh As Long
Dim StrikethroughFont As Long: StrikethroughFont = 0

If Len(ActiveCell) > 0  Then
    For iCh = 1 To Len(ActiveCell)
        With ActiveCell.Characters(iCh, 1)
            If .Font.Strikethrough = True Then
                StrikethroughFont = StrikethroughFont + 1
            End If
        End With
    Next iCh
End If

Code works as it should. Problem is that execution time increases exponentially with cell content length.

• with less than 100 characters in every cell, code runs superfast.
• with 1000 characters somewhere in 1 cell execution time is 30 seconds - still acceptable for the project
• with 3000 characters somewhere in 1 cell execution time about half an hour.
• with 5000 characters somewhere in 1 cell Excel continues to run seemingly forever, sometimes it crashes

I know that Excel is not intended for writing stories in a cell and revising them with strikethrough. But I have not control over what people do with these spreadsheets. Most people behave, but sometimes an individual exaggerates. I don't want this individual to make my work look bad. A not-so-nice workaround I found is adding a

And Len(ActiveCell) < 1000

statement to the first If, so that it completely skips cells with over 1000 characters. I'm fearing that Excel 2010 SP2 that I'm using is not handling the ActiveCell.Characters(iCh, 1) very well.
Any suggestions to speed things up?

Question update after reading the many valuable replies & comments As pointed out, I made an incorrect statement in my question on line 3 and update it now in order not to mislead readers who haven't read all comments yet:

ActiveCell.Font.Strikethrough 

Can actually detect partial strikethrough text in a cell: The possible return values are FALSE, TRUE and NULL, the latter meaning that there is a mix of strikethrough and normal font in the cell. This has no influence on the 'exponential' part of the question, but a lot on the 'workaround' part.

Answer 1

Try stopping excel from updating the screen as you are doing this. Usually this fixes all kinds of speed problems when running macros.

Application.ScreenUpdating = False

Dim iCh As Long
Dim StrikethroughFont As Long: StrikethroughFont = 0

If Len(ActiveCell) > 0  Then
    For iCh = 1 To Len(ActiveCell)
        With ActiveCell.Characters(iCh, 1)
            If .Font.Strikethrough = True Then
                StrikethroughFont = StrikethroughFont + 1
            End If
        End With
    Next iCh
End If

Application.ScreenUpdating = True

*Edit

As the above did not help at all, I just could not stop thinking how to fix this. AND HERE IT IS...

You need to add microsoft.wordXX object library as reference in your vba editor.

This counts 21000 words with 450 strikethrough words wich did not work att all in the above code, and here it takes about 3 secs now, using word as the counter and its counting WORDS with strikethrough. not nr of characters striketrhough. You can then afterwards loop through the words and count the caracters.

Sub doIt()


    Dim WordApp
    Dim WordDoc As Word.Document

    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = True ' change to false when ready :)

    Set WordDoc = WordApp.Documents.Add

    Range("a1").Copy
    Dim wdPasteRTF As Integer
    Dim wdInLine As Integer

    wdInLine = 0
    wdPasteRTF = 1

    WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _
    Placement:=wdInLine, DisplayAsIcon:=False

    Dim rngWords As Word.Range
    Set rngWords = WordDoc.Content
    Dim iStrikethrough As Long

    Do

    With rngWords.Find
        .Font.Strikethrough = True
        .Forward = True
        .Execute
    End With
    If rngWords.Find.Found = True Then
        iStrikethrough = iStrikethrough + rngWords.Words.Count
    Else
        Exit Do
    End If
    Loop
    MsgBox iStrikethrough

    WordDoc.Close savechanges:=False

    Set WordDoc = Nothing
    Set WordApp = Nothing

End Sub