丰富的文本格式（带有格式化标签）在Excel中无格式的文本
我有约。 包含RTF的excel中的12000个单元格（包括格式化标签）。 我需要parsing它们以得到未格式化的文本。
这是带有文本的一个单元格的示例：
{\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打开它，它立即parsing文本，我得到我想要的。 不幸的是，这对于12000个单元来说是非常不方便的。
所以我正在考虑VBAmacros，将单元格内容移动到Word，强制parsing，然后将结果复制回原始单元格。 不幸的是我不确定如何去做。
有人有什么想法吗？ 或者一个不同的方法？ 我将非常感激解决scheme或推动正确的方向。
TNX！
如果您确实想要使用Wordparsing文本的路线，该function应该可以帮助您。 如意见所示，您需要对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函数至less需要运行一秒钟（至less在我的机器上），所以对于12,000个单元格，大概需要三个半小时。
在周末考虑过这个问题之后，我确信有一个更好的（更快的）解决scheme。
我记得剪贴板的RTFfunction，并意识到可以创build一个类，将RTF数据复制到剪贴板，粘贴到Word文档，并输出生成的纯文本。 这个解决scheme的好处是doc对象不需要为每个rtfstring打开和closures; 它可以在循环之前打开并closures之后。
以下是实现这一目标的代码。 它是一个名为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
我在我的机器上使用示例RTFstring来模拟这个。 对于12000个电池，耗时2.5分钟，这是一个更合理的时间框架！
您可以尝试使用正则expression式parsing每个单元格，并只保留所需的内容。
每个RTF控制代码都以“\”开始，以空格结束，两者之间没有任何额外的空格。 “{}”用于分组。 如果您的文本不包含任何内容，您可以删除它们（“;”）。 所以，现在你留在你的文本和一些不必要的词作为“宋体”，“正常”等。你可以build立字典删除他们也。 经过一些调整，你将只留在你需要的文字。
看看http://www.regular-expressions.info/了解更多信息和伟大的工具来编写RegExp（RegexBuddy – 不幸的是它不是免费的，但它是值得的钱，AFAIR也有审判）。
更新：当然，我不鼓励你为每个细胞手动。 只需遍历活动范围：请参阅此线程： SO：关于迭代VBA中的单元格
就我个人而言，我会尝试这个想法：
Sub Iterate() For Each Cell in ActiveSheet.UsedRange.Cells 'Do something Next End Sub
以及如何在VBA（Excel）中使用RegExp？
请参阅： Excel中的正则expression式函数和VBA中的正则expression式
基本上你必须通过COM使用VBScript.RegExp对象。
这里的一些解决scheme需要对MS Word对象库的引用。 玩牌，我发现，我find了一个不依赖于它的解决scheme。 它剥离了RTF标签，以及其他绒毛，如字体表和样式表，全部在VBA中。 这可能对你有所帮助。 我运行它的数据，而不是空白，我得到了你所期望的相同的输出。
这是代码。
首先，检查一个string是否是字母数字。 给它一个长度为一个字符的string。 这个函数被用来在这里和那里进行定界。
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
一旦你将上面的函数复制粘贴到你的模块中，你可以创build一个函数来使用它们去除你不需要或者不需要的东西。 下面的例子对我来说是完美的。
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
我希望这有帮助。 我不会在文字处理器或任何东西中使用它，但是如果这就是你正在做的事情，它可能会用于抓取数据。