Более быстрые альтернативы объекту Персонажи

Question

От меня требуется извлекать отрывки текста из содержимого ячеек Excel, в которых создатель, по сути, вручную отслеживал изменения, используя шрифт Strikethrough. Отрывки можно идентифицировать с помощью определенных шаблонов символов, но я должен игнорировать зачеркнутые символы, чтобы их увидеть. Зачеркнутые символы не появляются в обычных местах в каждой ячейке, поэтому по сути случайным образом рассредоточены с обычным шрифтом.

Я достиг своей цели, используя VBA для Excel, но решение чрезвычайно (и практически невозможно) медленное. После поиска ответов на этом сайте и в Интернете, похоже, виновато использование объекта Characters.

Итак, мой вопрос: нашел ли кто-нибудь способ синтаксического анализа такого текста, который не включает объект Characters ?

Подложка, которую я написал для синтаксического анализа, слишком длинна, чтобы публиковать ее здесь, но ниже приведен тестовый код, который аналогичным образом использует объект 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

Answer 1

Вы правы, доступ к Characters очень медленный, поэтому вашей целью должно быть максимальное сокращение его использования.

Я не понимаю деталей ваших требований, но следующий код должен дать вам представление о том, как можно ускорить код. Он считывает содержимое ячейки только один раз, разбивает текст на отдельные строки, вычисляет положение отдельных символов перевода строки и просматривает эту позицию для форматирования. Насколько я знаю, нет возможности получить доступ к форматированию сразу, но теперь доступ к characters -объекту сокращен до одного на строку:

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 сохраняет Разрывы строк в ячейке с использованием только символа LineFeed, поэтому код проверяет только это.

Answer 2

Это может удовлетворить ваши потребности в производительности: он вызывает функцию, которая анализирует XML представление содержимого ячейки, удаляет зачеркнутые разделы и возвращает оставшийся текст.

Это будет намного быстрее чем цикл по Characters

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

EDIT: вот еще один способ go, разбив текст на «блоки» и проверив каждый блок, чтобы увидеть, есть ли в нем зачеркивание. Насколько это быстрее, чем посимвольно, может зависеть от размера блока и распределения зачеркнутого текста в каждой ячейке.

Function NoStrikeThrough2(c As Range)
    Const BLOCK As Long = 50
    Dim L As Long, i As Long, n As Long, pos As Long, x As Long
    Dim rv As String, s As String, v

    L = Len(c.Value)
    n = Application.Ceiling(L / BLOCK, 1) 'how many blocks to check
    pos = 1                               'block start position
    For i = 1 To n
        v = c.Characters(pos, BLOCK).Font.Strikethrough
        If IsNull(v) Then
            'if strikethough is "mixed" in this block - parse out
            '  character-by-character
            s = ""
            For x = pos To pos + BLOCK
                If Not c.Characters(x, 1).Font.Strikethrough Then
                    s = s & c.Characters(x, 1).Text
                End If
            Next x
            rv = rv & s
        ElseIf v = False Then
            'no strikethrough - take the whole block
            rv = rv & c.Characters(pos, BLOCK).Text
        End If
        pos = pos + BLOCK 'next block position.
    Next i
    NoStrikeThrough2 = rv
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