Как повысить производительность при переборе символов в ячейке Excel

Question

Я работаю над подпрограммой VBA для импорта материалов из Excel в Sparx Enterprise Architect.

Одна из проблем заключается в переводе форматированного текста (полужирный, курсив и подчеркивание). В своем тексте советник использует теги форматирования, похожие на html. Так вот:

этот текст имеет полужирный и курсив

должен быть переведен на это:

this text has <b>bold</b> and <i>italic</i>

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

'-------------------------------------------------------------
' Author:   Geert Bellekens (copied from stackoverflow: https://stackoverflow.com/questions/29916992/extract-text-content-from-cell-with-bold-italic-etc)
' Date:     02/09/2019
' Description: Returns a html formatted string for the (formatted) text in a cell
'-------------------------------------------------------------
Public Function getHTMLFormattedString(r As range) As String
 Dim startTimeStamp As Double
 startTimeStamp = Timer
 Dim isBold As Boolean
 Dim isItalic As Boolean
 Dim isUnderlined As Boolean
 isBold = False
 isItalic = False
 isUnderlined = False
 Dim text As String
 text = ""
 Dim cCount As Integer
 cCount = 0
 Dim modifiers As New Collection
 On Error Resume Next
 cCount = r.Characters.Count
 On Error GoTo 0
 If cCount > 0 Then
    For i = 1 To cCount
        Set c = r.Characters(i, 1)
        If isBold And Not c.Font.Bold Then
            isBold = False
            text = removeModifier("b", text, modifiers)
        End If
        If isItalic And Not c.Font.Italic Then
            isItalic = False
            text = removeModifier("i", text, modifiers)
        End If
        If isUnderlined And c.Font.Underline = xlUnderlineStyleNone Then
            isUnderlined = False
             text = removeModifier("u", text, modifiers)
        End If
        If c.Font.Bold And Not isBold Then
            isBold = True
            text = addModifier("b", text, modifiers)
        End If
        If c.Font.Italic And Not isItalic Then
            isItalic = True
            text = addModifier("i", text, modifiers)
        End If
        If Not (c.Font.Underline = xlUnderlineStyleNone) And Not isUnderlined Then
            isUnderlined = True
            text = addModifier("u", text, modifiers)
        End If
        text = text & c.text
        If i = cCount Then
            text = closeAllModifiers(text, modifiers)
        End If
    Next i
 Else
    text = r.text
    If r.Font.Bold Then
        text = "<b>" & text & "</b>"
    End If
    If r.Font.Italic Then
        text = "<i>" & text & "</i>"
    End If
    If Not (r.Font.Underline = xlUnderlineStyleNone) Then
        text = "<u>" & text & "</u>"
    End If
 End If
 'replace newline with CRLF
 text = Replace(text, Chr(10), vbNewLine)
 'return
 getHTMLFormattedString = text
 'get processingtime
 MsgBox "processed " & Len(text) & " characters in " & Format(Timer - startTimeStamp, "00.00") & " seconds"
End Function

Я тестировал этот код со строкой lorem ipsum из 1000 символов без какого-либо форматирования, и это обрабатывается за 4,89 секунды.

Вопрос : Что я могу сделать, чтобы улучшить производительность?

• Есть ли лучший способ зациклить все символы?
• Можно ли как-то определить, есть ли ячейка? не имеет форматирования вообще (и, следовательно, пропустить всю процедуру)?

Answer 1

Как я предложил в своих комментариях, я использовал Range.Value (Value.Type) для извлечения XML, а затем создал анализатор для извлечения текста в формате HTML

Sub ConvertCellTextToHTML()

    Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3")                   '< Change worksheet name
    Dim iLastRow As Long: iLastRow = oWS.Range("A" & oWS.Rows.Count).End(xlUp).Row
    Dim oRng As Range: Set oRng = oWS.Range("A1:A" & iLastRow)                          '< Change range as required
    Dim oCell As Range
    Dim oXml As MSXML2.DOMDocument                                                      '< Requires reference to Microsoft XML
    Dim sCellXML As String, sHTMLString As String

    ' Loop to go through all cells in the range
    For Each oCell In oRng.Cells

        ' Load XML for current cell
        Set oXml = New MSXML2.DOMDocument
        oXml.LoadXML (oCell.Value(xlRangeValueXMLSpreadsheet))

        ' Capture the XML just for the cell
        sCellXML = oXml.SelectSingleNode("/Workbook/Worksheet/Table/Row/Cell").XML

        ' Call the function to return HTML formated string
        sHTMLString = ExtractTextWithFont(sCellXML)
        Debug.Print sHTMLString
    Next

End Sub

Function ExtractTextWithFont(ByVal sXMLString As String) As String

    Dim sRetVal As String
    Dim aXML As Variant
    Dim iC As Long

    ' Split XML string
    aXML = Split(sXMLString, ">")

    ' Loop to go through all elements in the array - starting from third element because first 2 are just headers from what i can see
    For iC = LBound(aXML) + 2 To UBound(aXML)

        ' Building string - this is based on strings that i tested. You might need to amend this bit to meet your needs
        If Mid(Replace(Trim(LCase(aXML(iC))), "/", ""), 2, 4) <> "font" Then
            If Left(LCase(Trim(aXML(iC))), 4) <> "</ss" And Left(LCase(Trim(aXML(iC))), 4) <> "</ce" Then
                If Left(aXML(iC), 1) = "<" Then
                    sRetVal = sRetVal & Replace(aXML(iC), "</Font", "") & ">"
                Else
                    sRetVal = sRetVal & Replace(aXML(iC), "</Font", "")
                End If
                If LCase(Right(Trim(sRetVal), 6)) = "</data" Then
                    sRetVal = Mid(Trim(aXML(iC)), 1, Len(Trim(aXML(iC))) - 6)
                End If
            End If
        End If

    Next

    ' Set return value
    ExtractTextWithFont = sRetVal

End Function

Answer 2

По второму вопросу: чтобы проверить, не является ли текст неотформатированным (без жирного, курсива или подчеркивания), вы можете использовать:

If r.Font.FontStyle = "Regular" And r.Font.Underline = xlUnderlineStyleNone Then 
    getHTMLFormattedString = r.text
    Exit Function
End If

Вы также можете проверить, содержит ли текст смешанное форматирование, используя следующий код:

If IsNull(r.Font.Bold) Or IsNull(r.Font.Italic) Or IsNull(r.Font.Underline) Then 
'multiple format, check character-wise formatting here

Answer 3

Библиотеки Microsoft Office - один из самых медленных способов чтения и записи документов Office (я не знаю ни о каком более медленном способе). Кроме того, VBA ограничен одним потоком. Большая часть задержки связана со связью между библиотекой Office и языком. В вашем случае существует несколько вызовов библиотеки Excel для каждого символа.
Гораздо более быстрыми альтернативами являются библиотеки, такие как OpenXML , ClosedXML , EPPlus и т. Д. Большинство из них ограничены форматом файла xlsx, но библиотека NPOI , похоже, также поддерживает xls. Я не уверен, есть ли способ использовать любой из них с VBA, так как большинство из них для .Net и Java.

Если по какой-либо причине вы ограничены VBA, Range.Value(11) можно использовать для получения информации о форматировании в формате электронных таблиц XML, который можно обрабатывать с помощью VBA и библиотеки обработки XML.

Другой альтернативой может быть сохранение файла в формате html или mhtml и его обработка.