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

Question

我正在使用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秒的某个地方有1000个字符 - 仍然可以接受项目
• 在1个单元执行时间约有半个小时的某个地方有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,后者意味着单元格中有删除线和普通字体的混合.这对问题的"指数"部分没有影响,但对"解决方法"部分有很多影响.

Answer 1

尝试在执行此操作时阻止 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 秒，使用单词作为计数器并计算带有删除线的单词。没有删除线的字符。然后您可以循环遍历单词并计算字符数。

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