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
代码正常工作。 问题是执行时间随着单元内容长度呈指数增长。
- 在每个单元中less于100个字符，代码运行速度超快。
- 在1个单元执行时间内有1000个字符的地方是30秒 – 仍然可以接受该项目
- 在一个单元执行时间约半个小时的地方有3000个字符。
- 在1个单元格中有5000个字符的地方Excel继续运行似乎永远，有时它崩溃
我知道Excel并不是用来在单元格中编写故事，而是用删除线来修改它们。 但是我不能控制人们用这些电子表格做什么。 大多数人的行为，但有时一个人夸大。 我不希望这个人让我的工作看起来很糟糕。 我发现一个不太好的解决方法是添加一个
And Len(ActiveCell) < 1000
声明到第一个If，这样它就完全跳过超过1000个字符的单元格。 我担心我正在使用的Excel 2010 SP2并没有很好地处理ActiveCell.Characters（iCh，1）。
任何build议，以加快速度？
阅读了许多有价值的回复和评论之后的问题更新如前所述，我在第3行的问题中做了一个不正确的陈述，现在更新它，以免误导尚未阅读所有评论的读者：
ActiveCell.Font.Strikethrough
实际上可以检测单元格中的部分删除线文本：可能的返回值是FALSE，TRUE和NULL，后者表示单元格中有删除线和普通字体的混合。 这对问题的“指数”部分没有影响，但在“解决方法”部分很多。
尝试停止更新屏幕的Excel，因为你这样做。 通常这会在运行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
*编辑
由于上述根本没有帮助，我只是不能停止思考如何解决这个问题。 这里是…
您需要在vba编辑器中添加microsoft.wordXX对象库作为参考。
在上面的代码中，这个数字有21000个单词，有450个删除单词，但是这个过程大约需要3秒，用单词作为计数器，用单词作为计数器，并用删除线来计算单词。 不是字符罢工nrrrough。 然后你可以循环遍历单词并计算字符。
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
以下build议不直接解决您的问题。 但在某些情况下可能会有所帮助。
如果没有检查表格中的每个字符，则首先检查单元格是否存在任何受损的字符。 你需要的是以下逻辑：
'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您可以跳过单元格。
替代解决scheme
您可以将单元格文本分成几部分，并检查是否有任何字符。 以下解决scheme将执行时间从六秒缩短到两秒。
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
一般来说，任何一个范围的呼叫都是超重的。 我相当肯定你可以做同样的只有一个单元格的参考…