性能 – Excel vba执行时间与单元格内容长度成指数关联

我正在使用vba检查电子表格中的删除线文本.
如

ActiveCell.Font.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

代码可以正常工作.
问题是执行时间随着单元格内容的长度呈指数增长.

>每个单元格中的字符少于100个,代码运行速度超快.
> 1个单元格中的1000个字符执行时间为30秒 – 仍然可以接受项目
>在一个单元执行时间约半小时内某处有3000个字符.
>在1个单元格的某处有5000个字符Excel继续看似永远运行,有时会崩溃

我知道Excel不是用于在单元格中编写故事并用删除线修改它们.但我无法控制人们对这些电子表格的处理方式.大多数人表现得很好,但有时候个人会夸大其词.我不希望这个人让我的工作看起来很糟糕.
我发现一个不那么好的解决方法是添加一个

And Len(ActiveCell) < 1000

语句到第一个If,以便它完全跳过超过1000个字符的单元格.
我担心我使用的Excel 2010 SP2不能很好地处理ActiveCell.Characters(iCh,1).
有什么建议可以加快速度吗？

阅读了许多有价值的回复后,问题更新了评论
正如所指出的那样,我在第3行的问题中做了一个不正确的陈述并立即更新,以免误导尚未阅读所有评论的读者：

ActiveCell.Font.Strikethrough

实际上可以检测单元格中的部分删除线文本：可能的返回值是FALSE,TRUE和NULL,后者意味着单元格中有删除线和普通字体的混合.这对问题的“指数”部分没有影响,但对“解决方法”部分有很多影响.

尝试在执行此操作时停止excel更新屏幕.通常,这可以在运行宏时修复各种速度问题.

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

*编辑

由于上面没有任何帮助,我只是无法停止思考如何解决这个问题.在这里……

您需要在vba编辑器中添加microsoft.wordXX对象库作为参考.

这计算了21000个单词,其中450个删除词在上面的代码中并不起作用,现在大约需要3秒,使用word作为计数器,并使用删除线计算WORDS.不是很多人物.然后,您可以循环遍历单词并计算字符数.

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