Расширенный текстовый формат (с тегами форматирования) в Excel для неформатированного текста

Если вы действительно хотите пойти по пути использования Word для синтаксического анализа текста, эта функция должна вам помочь. Как следует из комментариев, вам понадобится ссылка на библиотеку объектов MS Word.

Function ParseRTF(strRTF As String) As String
Dim wdDoc As Word.Document 'Ref: Microsoft Word 11.0 Object Library'
Dim f     As Integer       'Variable to store the file I/O number'

'File path for a temporary .rtf file'
Const strFileTemp = "C:\TempFile_ParseRTF.rtf"

'Obtain the next valid file I/O number'
f = FreeFile

'Open the temp file and save the RTF string in it'
Open strFileTemp For Output As #f
    Print #f, strRTF
Close #f

'Open the .rtf file as a Word.Document'
Set wdDoc = GetObject(strFileTemp)

'Read the now parsed text from the Word.Document'
ParseRTF = wdDoc.Range.Text

'Delete the temporary .rtf file'
Kill strFileTemp

'Close the Word connection'
wdDoc.Close False
Set wdDoc = Nothing
End Function

Вы можете вызвать его для каждой из ваших 12000 ячеек, используя что-то вроде этого:

Sub ParseAllRange()
Dim rngCell As Range
Dim strRTF  As String

For Each rngCell In Range("A1:A12000")

    'Parse the cell contents'
    strRTF = ParseRTF(CStr(rngCell))

    'Output to the cell one column over'
    rngCell.Offset(0, 1) = strRTF
Next
End Sub

Функция ParseRTF запускается примерно за секунду (по крайней мере, на моей машине), поэтому для 12000 ячеек это сработает примерно за три с половиной часа.

Подумав об этой проблеме на выходных, я был уверен, что для нее есть лучшее (более быстрое) решение.

Я вспомнил возможности буфера обмена RTF и понял, что можно создать класс, который будет копировать данные RTF в буфер обмена, вставлять их в документ Word и выводить полученный простой текст. Преимущество этого решения состоит в том, что объект word doc не нужно открывать и закрывать для каждой строки rtf; его можно было открыть до цикла и закрыть после.

Ниже приведен код для этого. Это модуль класса clsRTFParser.

Private Declare Function GlobalAlloc Lib "kernel32" _
                (ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" _
                (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
                (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" _
                (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long

Private Declare Function OpenClipboard Lib "user32" _
                (ByVal Hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias _
                "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function SetClipboardData Lib "user32" _
                (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long

'---'

Dim wdDoc As Word.Document 'Ref: Microsoft Word 11.0 Object Library'

Private Sub Class_Initialize()
Set wdDoc = New Word.Document
End Sub

Private Sub Class_Terminate()
wdDoc.Close False
Set wdDoc = Nothing
End Sub

'---'

Private Function CopyRTF(strCopyString As String) As Boolean
Dim hGlobalMemory  As Long
Dim lpGlobalMemory As Long
Dim hClipMemory    As Long
Dim lngFormatRTF   As Long

'Allocate and copy string to memory'
hGlobalMemory = GlobalAlloc(&H42, Len(strCopyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString)

'Unlock the memory and then copy to the clipboard'
If GlobalUnlock(hGlobalMemory) = 0 Then
    If OpenClipboard(0&) <> 0 Then
        Call EmptyClipboard

        'Save the data as Rich Text Format'
        lngFormatRTF = RegisterClipboardFormat("Rich Text Format")
        hClipMemory = SetClipboardData(lngFormatRTF, hGlobalMemory)

        CopyRTF = CBool(CloseClipboard)
    End If
End If
End Function

'---'

Private Function PasteRTF() As String
Dim strOutput As String

'Paste the clipboard data to the wdDoc and read the plain text result'
wdDoc.Range.Paste
strOutput = wdDoc.Range.Text

'Get rid of the new lines at the beginning and end of the document'
strOutput = Left(strOutput, Len(strOutput) - 2)
strOutput = Right(strOutput, Len(strOutput) - 2)

PasteRTF = strOutput
End Function

'---'

Public Function ParseRTF(strRTF As String) As String
If CopyRTF(strRTF) Then
    ParseRTF = PasteRTF
Else
    ParseRTF = "Error in copying to clipboard"
End If
End Function

Вы можете вызвать его для каждой из ваших 12000 ячеек, используя что-то вроде этого:

Sub CopyParseAllRange()
Dim rngCell As Range
Dim strRTF  As String

'Create new instance of clsRTFParser'
Dim RTFParser As clsRTFParser
Set RTFParser = New clsRTFParser

For Each rngCell In Range("A1:A12000")

    'Parse the cell contents'
    strRTF = RTFParser.ParseRTF(CStr(rngCell))

    'Output to the cell one column over'
    rngCell.Offset(0, 1) = strRTF
Next
End Sub

Я смоделировал это на примере строк RTF на своей машине. Для 12000 ячеек потребовалось две с половиной минуты, гораздо более разумные сроки!

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

Каждый управляющий код RTF начинается с символа «\» и заканчивается пробелом без дополнительных пробелов между ними. "{}" используются для группировки. Если ваш текст не будет содержать их, вы можете просто удалить их (то же самое для ";"). Итак, теперь вы оставите свой текст и некоторые ненужные слова, такие как «Arial», «Normal» и т. Д. Вы можете создать словарь, чтобы удалить их. После некоторой настройки у вас останется только нужный текст.

Дополнительную информацию и отличный инструмент для напишите RegExp (RegexBuddy - к сожалению, это не бесплатно, но стоит своих денег. AFAIR есть также пробная версия).

ОБНОВЛЕНИЕ: конечно, я не рекомендую вам делать это вручную для каждой ячейки. Просто выполните итерацию по активному диапазону: обратитесь к этой теме: ТАК: Об итерации ячеек в VBA

Лично я попробую эту идею:

Sub Iterate()
   For Each Cell in ActiveSheet.UsedRange.Cells
      'Do something
   Next
End Sub

А как использовать RegExp в VBA (Excel)?

См .: Функции регулярных выражений в Excel и Regex в VBA

В основном вы должны использовать объект VBScript.RegExp через COM.

Для некоторых решений здесь требуется ссылка на библиотеку объектов MS Word. Играя с картами, которые мне выдали, я нашел решение, которое не полагается на это. Он удаляет теги RTF и прочую ерунду, такую ​​как таблицы шрифтов и таблицы стилей, и все это на VBA. Это может быть вам полезно. Я прогнал его по вашим данным и, кроме пробелов, получил тот же результат, что и вы ожидали.

Вот код.

Во-первых, что-то, чтобы проверить, является ли строка буквенно-цифровой или нет. Дайте ему строку длиной в один символ. Эта функция используется для определения границ здесь и там.

Public Function Alphanumeric(Character As String) As Boolean
   If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-", Character) Then
       Alphanumeric = True
   Else
       Alphanumeric = False
   End If
End Function

Далее следует удалить всю группу. Я использую это для удаления таблиц шрифтов и прочего мусора.

Public Function RemoveGroup(RTFString As String, GroupName As String) As String
    Dim I As Integer
    Dim J As Integer
    Dim Count As Integer

    I = InStr(RTFString, "{\" & GroupName)

    ' If the group was not found in the RTF string, then just return that string unchanged.
    If I = 0 Then
        RemoveGroup = RTFString
        Exit Function
    End If

    ' Otherwise, we will need to scan along, from the start of the group, until we find the end of the group.
    ' The group is delimited by { and }. Groups may be nested, so we need to count up if we encounter { and
    ' down if we encounter }. When that count reaches zero, then the end of the group has been found.
    J = I
    Do
        If Mid(RTFString, J, 1) = "{" Then Count = Count + 1
        If Mid(RTFString, J, 1) = "}" Then Count = Count - 1
        J = J + 1
    Loop While Count > 0

    RemoveGroup = Replace(RTFString, Mid(RTFString, I, J - I), "")

End Function

Хорошо, и эта функция удаляет все теги.

Public Function RemoveTags(RTFString As String) As String
    Dim L As Long
    Dim R As Long
    L = 1
    ' Search to the end of the string.
    While L < Len(RTFString)
        ' Append anything that's not a tag to the return value.
        While Mid(RTFString, L, 1) <> "\" And L < Len(RTFString)
            RemoveTags = RemoveTags & Mid(RTFString, L, 1)
            L = L + 1
        Wend
    
        'Search to the end of the tag.
        R = L + 1
        While Alphanumeric(Mid(RTFString, R, 1)) And R < Len(RTFString)
            R = R + 1
        Wend
        L = R
    Wend
End Function

Убрать фигурные скобки можно очевидным образом:

Public Function RemoveBraces(RTFString As String) As String
    RemoveBraces = Replace(RTFString, "{", "")
    RemoveBraces = Replace(RemoveBraces, "}", "")
End Function

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

Public Function RemoveTheFluff(RTFString As String) As String
    RemoveTheFluff = Replace(RTFString, vbCrLf, "")
    RemoveTheFluff = RemoveGroup(RemoveTheFluff, "fonttbl")
    RemoveTheFluff = RemoveGroup(RemoveTheFluff, "colortbl")
    RemoveTheFluff = RemoveGroup(RemoveTheFluff, "stylesheet")
    RemoveTheFluff = RemoveTags(RemoveBraces(RemoveTheFluff))
End Function

Надеюсь, это поможет. Я бы не стал использовать его в текстовом редакторе или в чем-то еще, но он может пригодиться для очистки данных, если вы это делаете.

Ваш пост звучал так, как будто каждый документ RTF хранился в одной ячейке Excell. Если да, то

Решение с использованием элемента управления RichTextBox .Net Framework

преобразует RTF в каждой ячейке в обычный текст в 2 строки кода (после небольшой настройки системы, чтобы получить правильный файл .tlb, позволяющий ссылаться на .Net Framework). Поместите значение ячейки в rtfsample и

Set miracle = New System_Windows_Forms.RichTextBox
With miracle
    .RTF = rtfText
    PlainText = .TEXT
End With