Excel 更快地替代字符对象

我需要从Excel单元格的内容中提取文本段落，在这些单元格中，发起者基本上使用删除线字体进行了手动跟踪更改。这些段落可以通过某些字符模式识别，但我必须忽略删除线字符才能看到它们。删除线字符不会出现在每个单元格中的常规位置，因此基本上与普通字体文本一起随机分布

我已经使用VBA for Excel实现了我的目标，但是解决方案非常慢（而且不切实际）。在搜索了这个网站和更广泛的网络来寻找答案后，似乎应该归咎于角色对象的使用

所以我的问题是：有没有人找到一种不涉及Characters对象的文本解析方法

我编写的用于解析的sub太长，无法在这里发布，但下面是一些测试代码，它以类似的方式使用Characters对象。解析一个包含3000个字符的单元格需要60秒。以这样的速度，我将需要50个小时来处理我收到的整个电子表格

Private Sub FindLineBreakChars(TargetCell As Excel.Range)

Dim n As Integer
Dim ch As String
Dim st As Boolean

If TargetCell.Cells.Count <> 1 Then
    Call MsgBox("Error: more or less than one cell in range specified.")
Else
    If IsEmpty(TargetCell.Value) Then
        Call MsgBox("Error: target cell is empty.")
    Else
        If Len(TargetCell.Value) = 0 Then
             Call MsgBox("Error: target cell contains an empty string.")
        Else
            'Parse the characters in the cell one by one.
            For n = 1 To TargetCell.Characters.Count
                ch = TargetCell.Characters(n, 1).Text
                st = TargetCell.Characters(n, 1).Font.Strikethrough
                If ch = vbCr Then
                    Debug.Print "#" & n & ": Carriage Return (vbCr)" & ", strikethrough = " & st & vbCrLf
                ElseIf ch = vbLf Then
                    Debug.Print "#" & n & ": Line Feed (vbLf)" & ", strikethrough = " & st & vbCrLf
                End If
            Next n
        End If
    End If
End If

End Sub

Private子FindLineBreakChars（TargetCell作为Excel.Range）
作为整数的Dim n
调暗琴弦
Dim st为布尔型
如果TargetCell.Cells.Count为1，则
调用MsgBox（“错误：指定范围内的单元格多于或少于一个。”）
其他的
如果为空（TargetCell.Value），则
调用MsgBox（“错误：目标单元格为空”）
其他的
如果Len（TargetCell.Value）=0，则
调用MsgBox（“错误：目标单元格包含空字符串。”）
其他的
'逐个解析单元格中的字符。
对于n=1到TargetCell.Characters.Count
ch=TargetCell.Characters（n，1）.Text
st=TargetCell.Characters（n，1）.Font.删除线
如果ch=vbCr，则
调试。打印“#”&n&”：回车（vbCr）&”，删除线=“&st&vbCrLf”
ElseIf ch=vbLf然后
调试。打印“#”&n&”：换行符（vbLf）&”，删除线=“&st&vbCrLf
如果结束
下一个
如果结束
如果结束
如果结束
端接头

你说得对，访问

字符的速度非常慢，因此你的目标应该是尽可能减少其使用量

我不了解您的需求细节，但是下面的代码应该会让您了解如何加快代码的速度。它只读取一次单元格内容，将文本拆分为单独的行，计算单个换行字符的位置，并查看该位置的格式设置。据我所知，无法一次访问所有格式，但现在对
字符
-对象的访问减少到每行一个：

With TargetCell 
    Dim lines() As String, lineNo As Integer, textLen As Long
    lines = Split(.Value2, vbLf)
    textLen = Len(lines(0)) + 1
    For lineNo = 1 To UBound(lines)
        Dim st
        st = .Characters(textLen, 1).Font.Strikethrough
        Debug.Print "#" & textLen & ": LineFeed (vbLf) strikethrough = " & st
        textLen = textLen + Len(lines(lineNo)) + 1
    Next lineNo
End With

据我所知，Excel仅使用换行符将换行符存储在单元格中，因此代码仅检查换行符。
这可能满足您的性能需要：它调用一个函数，解析单元格内容的XML表示形式，删除删除的部分，并返回剩余的文本

它将比在
字符上循环快得多

Sub Tester()

    Debug.Print NoStrikeThrough(Range("A1"))

End Sub

'Needs a reference to Microsoft XML, v6.0
'  in your VBA Project references
Function NoStrikeThrough(c As Range) '
    Dim doc As New MSXML2.DOMDocument60, rv As String
    Dim x As MSXML2.IXMLDOMNode, s As MSXML2.IXMLDOMNode
    'need to add some namespaces
    doc.SetProperty "SelectionNamespaces", _
                    "xmlns:ss='urn:schemas-microsoft-com:office:spreadsheet' " & _
                    "xmlns:ht='http://www.w3.org/TR/REC-html40'"
    doc.LoadXML c.Value(11) 'cell data as XML
    Set x = doc.SelectSingleNode("//ss:Data")'<< cell content
    Set s = x.SelectSingleNode("//ht:S")     '<< strikethrough
    Do While Not s Is Nothing
        Debug.Print "Struck:", s.Text
        x.RemoveChild s '<< remove struck section
        Set s = x.SelectSingleNode("//ht:S")
    Loop
    NoStrikeThrough = doc.Text
End Function

EDIT2：如果您需要确保在处理单元格之前没有删除所有换行符-

Sub ClearParaStrikes(c As Range)
    Dim pos As Long
    pos = InStr(pos + 1, c.Value, vbLf)
    Do While pos > 0
        Debug.Print "vbLf at " & pos
        c.Characters(pos, 1).Font.Strikethrough = False
        pos = InStr(pos + 1, c.Value, vbLf)
    Loop
End Sub

我不太明白你在问什么，你能不能得到单元格的值，然后在回车时分割得到一个行数组？不幸的是，这不是那么简单，因为我还必须检查每行的字符。上面的代码不是我想要做的，它只是一个类似的示例，说明了我如何使用Characters对象。我试图编辑我的原始帖子并上载所需前后结果的图像，但不允许加载图像。此外，OP可以将输出缓存到数组中，而不是使用Debug.PrintAll。Split（）建议似乎是我最好的选择。我希望我能加载一张图片来清楚地展示一个挑战的例子，但是网站说我没有足够的分数。蒂姆，哇。我尝试了你的第一个建议，这是一个巨大的进步——在我提到的同一个3000字符的电池上，速度快了大约2000倍（我计时了）。我很高兴我注册了这个论坛，因为我不认为我会发现这些XML例程。它们不会出现在Office开发中心的联机帮助中。谢谢。我不得不将Microsoft XML v6.0引用添加到VBA工作台来运行它。除了另一个奇妙的发现——正则表达式，这项工作现在基本上解决了，但还有最后一个问题。单元格中用于划分文本段落的换行符有时会使用删除线格式。当它们被删除时，根据客户编写段落编号的方式，这会妨碍我对段落编号的正则表达式搜索（（^\n ^/）\d+\）。那么，有没有一种方法可以修改NoStrikeThrough（），使其不受换行操作的影响？我已经尝试过在线筛选MSXML文档，但是当您从头开始时，有很多东西需要学习。在继续处理单元格之前，找到所有vbLf字符并将其删除设置为False非常简单。。。
Sub ClearParaStrikes(c As Range)
    Dim pos As Long
    pos = InStr(pos + 1, c.Value, vbLf)
    Do While pos > 0
        Debug.Print "vbLf at " & pos
        c.Characters(pos, 1).Font.Strikethrough = False
        pos = InStr(pos + 1, c.Value, vbLf)
    Loop
End Sub