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

У меня ок. 12000 ячеек в excel, содержащих RTF (включая теги форматирования). Мне нужно разобрать их, чтобы перейти к неформатированному тексту.

Это пример одной из ячеек с текстом:

{\rtf1\ansi\deflang1060\ftnbj\uc1 {\fonttbl{\f0 \froman \fcharset0 Times New Roman;}{\f1 \fswiss \fcharset238 Arial;}} {\colortbl ;\red255\green255\blue255 ;\red0\green0\blue0 ;} {\stylesheet{\fs24\cf2\cb1 Normal;}{\cs1\cf2\cb1 Default Paragraph Font;}} \paperw11908\paperh16833\margl1800\margr1800\margt1440\margb1440\headery720\footery720 \deftab720\formshade\aendnotes\aftnnrlc\pgbrdrhead\pgbrdrfoot \sectd\pgwsxn11908\pghsxn16833\marglsxn1800\margrsxn1800\margtsxn1440\margbsxn1440 \headery720\footery720\sbkpage\pgncont\pgndec \plain\plain\f1\fs24\pard TPR 0160 000\par IPR 0160 000\par OB-R-02-28\par} 

И все, что мне действительно нужно, это:

 TPR 0160 000 IPR 0160 000 OB-R-02-28 

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

Но если я скопирую содержимое одной ячейки, чтобы очистить текстовый документ и сохранить его как RTF, тогда откройте его с помощью MS Word, он мгновенно проанализирует текст, и я получаю именно то, что хочу. К сожалению, это очень неудобно для 12000 ячеек.

Поэтому я думал о макросе VBA, перемещать содержимое ячейки в Word, синтаксический анализ и затем копировать результат обратно в исходную ячейку. К сожалению, я не уверен, как это сделать.

Кто-нибудь знает? Или другой подход? Я буду очень благодарен за решение или толчок в правильном направлении.

TNX!

Если вы хотите пойти по пути использования 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 

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

 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 занимает около секунды для запуска (по крайней мере, на моей машине), поэтому для 12 000 ячеек это будет работать примерно через три с половиной часа.


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

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

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

 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 на моей машине. Для 12 000 ячеек потребовалось две с половиной минуты, гораздо более разумные временные рамки!

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

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

Посмотрите на http://www.regular-expressions.info/ для получения дополнительной информации и отличного инструмента для написания RegExp (RegexBuddy – к сожалению, он не является бесплатным, но он стоит денег. AFAIR также пробный).

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

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

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

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

См. Функции Regex в Excel и Regex в VBA

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

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

Вот код.

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

 Public Function Alphanumeric(Character As String) As Boolean If InStr("ABCDEFGHIJKKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-", 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 

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

Давайте будем гением компьютера.