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

Answer 2

The following suggestion doesn't directly address your problem. But could be helpful in some situation.

Instead of checking each character in your sheet check cells first if there is any strikethrought character inside. What you need is the following logic:

'if activecell is fully Strikethrough, the following line:
 Debug.Print Activecell.Font.Strikethrough    '>> you get TRUE result

'if activecell has at min. one character strikethrought then the following line:
 Debug.Print Activecell.Font.Strikethrough    '>> will result with NULL

'if there is nothing in activecell which is Strikethrought, then
 Debug.Print Activecell.Font.Strikethrough    '>> you get FALSE result

For either TRUE or NULL you will do what you need. For FALSE you can skip the cell.

ALTERNATIVE SOLUTION

You could divide cell text into parts and check if there is any character you look for. The following solution reduced execution time from six to two seconds.

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

Dim intStep As Integer
    intStep = 50       'make some experiments to find optimal range
Dim iPart As Integer

If Len(ActiveCell) > 0 Then
    'divide text into pices
    For iPart = 0 To Int(Len(ActiveCell) / intStep) + 1

        If ActiveCell.Characters(iPart * intStep + 1, intStep).Font.Strikethrough = True Or _
            IsNull(ActiveCell.Characters(iPart * intStep + 1, intStep).Font.Strikethrough) Then

            'run only if there is at min. one character to count
            For iCh = (iPart * intStep + 1) To ((iPart + 1) * intStep)
                If iCh > Len(ActiveCell) Then Exit For     'additional condition
                With ActiveCell.Characters(iCh, 1)
                    If .Font.Strikethrough = True Then
                        StrikethroughFont = StrikethroughFont + 1
                    End If
                End With

            Next iCh
        End If
    Next iPart
End If

Answer 3

In general, any call to a range is super heavy. I am pretty sure you can do the same with only one reference to the cell...