Modifying Microsoft Word VBA macro to call additional text from external file and add to footnote

Question

I'm working with an MS Word macro that currently calls data from an external Excel file, for a find/replace procedure in a long MS Word text. In my Excel file, Columns A has the words I want to find and Column B the words to replace with. Each change the macro performs, gets underlined and also a footnote is created on the text.

Now I need to have the macro add yet additional information about the change and also put it in the footnote. I have what I want to add, ready to go in Columns C of my Excel sheet.

More simply put: My code is already getting data from Columns A and B and putting it in the footnote. So, all I need to do now is, tell it to get the data ALSO from Column C. How do I do that?

Here's the full code:

1 standard module:

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 of 2 class modules (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 of 2 class modules (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

Come of my variable names may have changed since the last answer, so you'll need to make it all mesh together. Change your Term class to this

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

This makes the Let part of Footnote a place to store what you have in column C. The Get part then let's you define how you want to output the footnote. In this example, I'm reading in column C (in the next section), but when I get the footnote property, it concatenates some other terms - it's not a straight read-back of what is in column C. You can change the Get part of Footnote to make it whatever you want.

Next you need to change how the Excel file is read in.

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

I increased the range to include Column C. Before, Footnote was a concatenation of A and B. Now it is whatever is in column C and the concatenation is done in the class, where it should be.

I didn't save the file from the last question, so some of the variables and property names may have changed. Hopefully it's clear enough that you can adapt it.