修改Microsoft Word VBA宏以從外部文件中調用其他文本並添加到腳註

Question

我正在使用MS Word宏，該宏當前調用外部Excel文件中的數據以查找/替換過程中的長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 

1 2的類模塊（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

來吧o f自從最後一個答案以來，我的變量名稱可能已經發生了變化，因此您需要將它們全部網格化在一起。更改期限類此

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 

這使得腳註的部分讓我們來存儲你所擁有的在C列的獲取部分，然後讓你定義如何輸出腳註的一個地方。在這個例子中，我正在閱讀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和級聯在類中完成，它應該在哪裏。

我沒有保存最後一個問題的文件，所以一些變量和屬性名稱可能已經改變。希望很明顯，你可以適應它。