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

Posted 2023-05-07

【中文标题】Excel vba 执行时间与单元格内容长度呈指数关系

【英文标题】：Excel vba execution time exponentially related to cell content length

【发布时间】：2014-04-01 03:52:01

【问题描述】：

我正在使用 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 秒 - 对于项目来说仍然可以接受 在大约半小时的 1 个单元格中某处包含 3000 个字符。 1 个单元格中某处有 5000 个字符，Excel 似乎永远运行，有时会崩溃

我知道 Excel 不适用于在单元格中编写故事并使用删除线对其进行修改。但我无法控制人们如何使用这些电子表格。大多数人都表现得很好，但有时有些人会夸大其词。我不希望这个人让我的工作看起来很糟糕。 我发现一个不太好的解决方法是添加一个

And Len(ActiveCell) < 1000

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

阅读了许多有价值的回复和cmets后的问题更新 正如所指出的，我在第 3 行的问题中做了一个错误的陈述，现在更新它，以免误导尚未阅读所有 cmets 的读者：

ActiveCell.Font.Strikethrough 

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

【问题讨论】：

您需要计算或只知道单元格中是否存在？如果是这样，只需使用 Do while 循环，该循环将在找到第一个删除线字符时退出。或使用退出。

你能再给我们看一点代码吗，因为我和 Cronando 都无法复制缓慢

从MSDN's dev reference 看来Characters 不是一个集合。它是一个对象，表示对象文本中的一系列字符。这意味着每次访问cell.Characters 时都会创建一个Characters 类型的新对象。这可以解释为什么时间会随着字符数的增加而增加。

【参考方案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 秒，使用 word 作为计数器，它的计数 WORDS 带删除线。不是 nr 的字符前锋。然后，您可以循环遍历单词并计算字符。

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

【讨论】：

它没有多大帮助，代码没有访问屏幕:)

你试过用 3000 个删除线字符运行这个吗？结果明显更好吗？与 OP 的测试相比，它们是什么？对我来说，3800 个字符的时间没有区别。为什么它没有区别？因为电子表格上没有修改任何内容，所以您 .ScreenUpdating 在这种情况下实际上什么都不做。

Application.ScreenUpdating = False 已经在里面了。 （我只复制了代码的问题部分）

在 Excel 2010 瑞典语/挪威语专业版中，有 21729 个字符和所有带有删除线的字符。屏幕更新开启 = 4 秒屏幕更新关闭 = 2 秒

再次，代码无法访问屏幕，我在 1000 次迭代循环中测试，所用时间完全相同……那一定是同一种奇迹

【参考方案2】：

以下建议并未直接解决您的问题。但在某些情况下可能会有所帮助。

不要先检查工作表中的每个字符，而是先检查单元格中是否有删除线字符。您需要的是以下逻辑：

'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

对于TRUE 或NULL，您将做您需要的事情。对于FALSE，您可以跳过单元格。

替代解决方案

您可以将单元格文本分成几部分，然后检查是否有您要查找的字符。以下解决方案将执行时间从六秒减少到两秒。

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

【讨论】：

我认为 OP 已经知道很多了。我认为问题在于，当单元格中有更多字符时，当前算法会增加其执行时间。 我认为 OP 正在寻找一种更快的方式来访问 Range 内特定来源的Characters

@mehow，是的，我很同意你的观点，我在问题下看到了你有趣的评论。但是，我认为问题中可能缺少一些逻辑，因此我决定在答案的开头添加一句话并保留它。

仍然有帮助我同意，但我认为这不能回答我要坚持的问题，直到 OP 给出进一步的解释。

@mehow，您对提出的新解决方案有何看法？

在 OP 澄清需要哪些信息之前，我不能说太多。如果他想要计算被击中字符的数量，或者只是想知道是否有......你的解决方案将时间减少了 50%，所以我想没关系 :)

【参考方案3】：

通常，对范围的任何调用都非常繁重。我很确定你可以只引用一个单元格来做同样的事情......