我正在使用一个 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
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