修改 Microsoft Word VBA 宏以从外部文件调用附加文本并添加到脚注

Question

我正在使用当前从外部 Excel 文件调用数据的 MS Word 宏，用于在长 MS Word 文本中查找/替换过程。在我的 Excel 文件中，A 列包含我要查找的单词，B 列包含要替换的单词。宏执行的每项更改都带有下划线，并且还会在文本上创建一个脚注。

现在我需要让宏添加有关更改的其他信息，并将其放在脚注中。我有我想要添加的内容，准备好进入我的 Excel 工作表的 C 列。

更简单地说：我的代码已经从 A 列和 B 列获取数据并将其放在脚注中。所以，我现在需要做的就是，告诉它也从 C 列获取数据。我该怎么做？

这是完整的代码：

1个标准模块：

Option Explicit

Dim m_oCol1                     As Collection
Dim m_oCol2                     As Collection

Sub ReplaceWordsAndDefineFootnotes()
    Dim clsTL                   As clsTerms
    Dim lngIndex                As Long

    Set clsTL = New clsTerms
    clsTL.FillFromExcel
    Set m_oCol1 = New Collection
    For lngIndex = 1 To clsTL.Count
        'Replace each defined English word with it Hebrew equivelent.
        ReplaceWords clsTL.Items(lngIndex).English, clsTL.Items(lngIndex).Hebrew
    Next lngIndex
    Underline_And_DefineFootnote
    For lngIndex = 1 To clsTL.Count
        'Replace temporary footnote text with with class defined footnote text.
        FixFootnotes clsTL.Items(lngIndex).Hebrew, clsTL.Items(lngIndex).Footnote
    Next lngIndex
lbl_Exit:
    Exit Sub
End Sub

Function DefinedTerms() As Collection
    Dim arrEng()                As String
    Dim arrHeb()                As String
    Dim lngIndex                As Long
    Dim oCol                    As Collection
    Dim Term                    As clsTerm

    'Note: Data arrays are used in this example.  In practice the data could come from a Word table, Excel worksheet or other data source.
    'arrEng = Split("God,heaven,earth,waters,good", ",")
    'arrHeb = Split("Elohim,shamayim,aretz,mayim,tov", ",")

    Set oCol = New Collection
    'Put data in the collection.
    For lngIndex = 0 To UBound(arrEng)
        Set Term = New clsTerm
        Term.English = arrEng(lngIndex)
        Term.Hebrew = arrHeb(lngIndex)
        Term.Footnote = arrEng(lngIndex) & ":" & arrHeb(lngIndex)
        'Term.FootnoteText = varWords(lngIndex, 3) & ":" & varWords(lngIndex, 1)
        oCol.Add Term, Term.English
    Next lngIndex
    Set DefinedTerms = oCol
lbl_Exit:
    Exit Function
End Function

Sub ReplaceWords(ByVal strFind As String, ByVal strReplaceWith As String)
    Dim oRng                    As Word.Range
    'Add each term processed to a collection.
    m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
    Set oRng = ActiveDocument.Range
    'Replace each instance of the English word with its Hebrew equivalent.
    With oRng.Find
        .Text = strFind
        .Replacement.Text = strReplaceWith
        .MatchWholeWord = True
        .MatchCase = False
        .Execute Replace:=wdReplaceAll
    End With
lbl_Exit:
    Exit Sub
End Sub

Sub Underline_And_DefineFootnote()
    Dim oRng                    As Word.Range
    Dim lngIndex                As Long
    Dim oWord                   As Word.Range
    Dim strWord                 As String
    Dim lngCounter              As Long
    Dim lngPages                As Long

    With ActiveDocument
        Set oRng = .Range
        lngPages = .ComputeStatistics(wdStatisticPages)
        For lngIndex = 1 To lngPages
Reprocess:
            Set m_oCol2 = New Collection
            Set oRng = oRng.GoTo(What:=wdGoToPage, Name:=lngIndex)
            Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\page")
            lngCounter = 1
            With oRng
                For Each oWord In oRng.Words
                    'Modify the word range to strip off white space.  We want only the text portion of the word range.
                    strWord = UCase(Trim(oWord.Text))
                    oWord.Collapse wdCollapseStart
                    oWord.MoveEnd wdCharacter, Len(strWord)
                    If oWord.Characters.Last = Chr(160) Then oWord.MoveEnd wdCharacter, -1
                    'We need to know if the text defined by the word range is a word we want to process.
                    'We added all of those words to a collection during the find and replace process.
                    'If we try to add one of those words to the collection again then it will error and we will know _
                     we are dealing with a word we want to process.
                    On Error Resume Next
                    m_oCol1.Add strWord, strWord
                    If Err.Number <> 0 Then
                        On Error GoTo 0
                        On Error Resume Next
                        'We only want to underline and footnote the first instance of the term on each page.
                        'So add the term and key to a collection.
                        m_oCol2.Add strWord, strWord
                        oWord.Font.Underline = 1
                        If Err.Number = 0 Then
                            'There was no error so underline the term and footnote it.
                            'oWord.Font.Underline = 1
                            On Error GoTo 0
                            ActiveDocument.Footnotes.Add oWord, CStr(lngCounter), LCase(strWord)
                            lngCounter = lngCounter + 1
                        End If
                    Else
                        'The word wasn't a word we want to process so remove it from the collection.
                        m_oCol1.Remove m_oCol1.Count
                    End If
                Next oWord
            End With
            'Since processing words will add footnotes, the length of the document will increase.
            'I'm using this method to reenter the processing loop.
            lngPages = .ComputeStatistics(wdStatisticPages)
            If lngIndex < lngPages Then
                lngIndex = lngIndex + 1
                GoTo Reprocess
            End If
        Next lngIndex
    End With
    Set oRng = Nothing
End Sub

Sub FixFootnotes(ByVal strFind As String, ByVal strReplaceWith As String)
    Dim oRng                    As Word.Range
    m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
    Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
    With oRng.Find
        .Text = strFind
        .Replacement.Text = strReplaceWith
        .MatchWholeWord = True
        .MatchCase = False    'True
        .Execute Replace:=wdReplaceAll
    End With
lbl_Exit:
    Exit Sub
End Sub

2 个类模块中的 1 个 (clsTerm)：

Option Explicit

Private msEnglish As String
Private msHebrew As String
Private msFootnote As String
Public Property Let English(ByVal sEnglish As String): msEnglish = sEnglish: End Property
Public Property Get English() As String: English = msEnglish: End Property
Public Property Let Hebrew(ByVal sHebrew As String): msHebrew = sHebrew: End Property
Public Property Get Hebrew() As String: Hebrew = msHebrew: End Property
Public Property Let Footnote(ByVal sFootnote As String): msFootnote = sFootnote: End Property

Public Property Get Footnote() As String

    Footnote = msEnglish & ":" & msHebrew & " - " & msFootnote

End Property

2 个类模块中的 2 个 (clsTerms)：

Option Explicit

Private mcolTerms                As Collection
Private lngCount                As Long

Property Get Items() As Collection
    Set Items = mcolTerms
End Property

Property Set Items(oCol As Collection)
    Set mcolTerms = oCol
End Property

Property Get Count() As Long
    If Not mcolTerms Is Nothing Then
        Count = mcolTerms.Count
    Else
        Count = 0
    End If
End Property

Public Sub FillFromExcel()

    Dim xlApp As Object
    Dim xlWb As Object
    Dim vaWords As Variant
    Dim cTerm As clsTerm
    Dim i As Long

    Const sFILE As String = "C:\Documents and Settings\Administrator\Desktop\Macro Latest Accomplishments\this_feeds_AlexfromZackMacro.xlsx"
    Const xlUP As Long = -4162

    Set mcolTerms = New Collection

    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open(sFILE, , True)

    With xlWb.Worksheets(1)
        'changed 2 to 3 to get column c
        vaWords = .Range("A1", .Cells(.Rows.Count, 3).End(xlUP)).Value
    End With

    'change footnote to store column c
    For i = LBound(vaWords, 1) To UBound(vaWords, 1)
        Set cTerm = New clsTerm
        cTerm.English = vaWords(i, 1)
        cTerm.Hebrew = vaWords(i, 2)
        cTerm.Footnote = vaWords(i, 3)
        mcolTerms.Add cTerm
    Next i

    xlWb.Close False
    xlApp.Quit

End Sub

Answer 1

自上次回答以来，我的变量名称可能已更改，因此您需要将它们全部融合在一起。将您的 Term 类更改为此

Option Explicit

Private msEnglish As String
Private msHebrew As String
Private msFootnote As String

Public Property Let English(ByVal sEnglish As String): msEnglish = sEnglish: End Property
Public Property Get English() As String: English = msEnglish: End Property
Public Property Let Hebrew(ByVal sHebrew As String): msHebrew = sHebrew: End Property
Public Property Get Hebrew() As String: Hebrew = msHebrew: End Property
Public Property Let Footnote(ByVal sFootnote As String): msFootnote = sFootnote: End Property

Public Property Get Footnote() As String

    Footnote = msEnglish & ":" & msHebrew & " - " & msFootnote

End Property

这使得脚注的 Let 部分可以存储 C 列中的内容。然后 Get 部分让您定义要如何输出脚注。在此示例中，我正在阅读 C 列（在下一节中），但是当我获得脚注属性时，它会连接一些其他术语 - 这不是对 C 列中内容的直接回读。您可以更改获取脚注的一部分，让它随心所欲。

接下来您需要更改 Excel 文件的读取方式。

Public Sub FillFromExcel()

    Dim xlApp As Object
    Dim xlWb As Object
    Dim vaWords As Variant
    Dim clsTerm As cTerm
    Dim i As Long

    Const sFILE As String = "C:\Users\Dick\Documents\My Dropbox\Excel\wordlist.xlsx"
    Const xlUP As Long = -4162

    Set mcolTerms = New Collection

    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open(sFILE, , True)

    With xlWb.Worksheets(1)
        'changed 2 to 3 to get column c
        vaWords = .Range("A1", .Cells(.Rows.Count, 3).End(xlUP)).Value
    End With

    'change footnote to store column c
    For i = LBound(vaWords, 1) To UBound(vaWords, 1)
        Set clsTerm = New cTerm
        clsTerm.English = vaWords(i, 1)
        clsTerm.Hebrew = vaWords(i, 2)
        clsTerm.Footnote = vaWords(i, 3)
        mcolTerms.Add clsTerm
    Next i

    xlWb.Close False
    xlApp.Quit

End Sub

我增加了范围以包括 C 列。以前，脚注是 A 和 B 的连接。现在它是 C 列中的任何内容，并且连接在类中完成，它应该在哪里。

我没有保存上一个问题的文件，因此某些变量和属性名称可能已更改。希望它足够清楚，您可以对其进行调整。