5

我正在使用 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) 。
有什么建议可以加快速度吗？

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

ActiveCell.Font.Strikethrough

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

4

3 回答 3

3

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

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

'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
于 2014-02-28T09:33:36.633 回答
3

尝试在执行此操作时阻止 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
于 2014-02-28T08:47:59.650 回答
0

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

于 2016-09-30T14:18:34.833 回答