Excel 中的富文本格式（带有格式化标签）为无格式文本

Question

我有大约。 Excel 中包含 RTF（包括格式标签）的 12000 个单元格。我需要解析它们才能获取未格式化的文本。

这是带有文本的单元格之一的示例：

{\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，强制解析，然后将结果复制回原始单元格。不幸的是我不太确定该怎么做。

有人有什么想法吗？或者有不同的方法？我将非常感谢您提供解决方案或推动正确的方向。

天啊！

Answer 1

如果您确实想沿着使用 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 文档，并输出生成的纯文本。该解决方案的好处是不必为每个 rtf 字符串打开和关闭单词 doc 对象；它可以在循环之前打开并在循环之后关闭。

下面是实现此目的的代码。它是一个名为 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 个细胞，需要两分半钟，这是一个更合理的时间范围！

Answer 2

您可以尝试用正则表达式解析每个单元格，只留下您需要的内容。

每个 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

And how to use RegExp's in VBA (Excel)?

参考：
Excel 中的正则表达式函数
和
VBA 中的正则表达式

基本上，您必须通过 COM 使用 VBScript.RegExp 对象。

Answer 3

这里的一些解决方案需要引用 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

我希望这有帮助。我不会在文字处理器或其他任何东西中使用它，但如果这就是你正在做的事情，它可能会用于抓取数据。

Answer 4

您的帖子听起来好像每个 RTF 文档都存储在单个 Excel 单元格中。如果是这样，那么

使用.Net Framework RichTextBox控件的解决方案

将通过两行代码将每个单元格中的RTF转换为纯文本（经过一些系统配置以获得正确的 .tlb 文件以允许引用 .Net Framework）。将单元格值放入 rtfsample 中并

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