我的项目是更改整本圣经中的单词/短语，并且我有包含圣经的 Word 文档，另外，我有一个 Excel 文件，其中包含需要由宏找到的 A 列旧词，B 列新词将取代旧的。
我收到了这个宏，它在 MS Word 2010 中运行良好，但正如您所见，它被设置为使用数据数组。它甚至说，“'注意：此示例中使用了数据数组。实际上，数据可能来自 Word 表格、Excel 工作表或其他数据源。”。因此，我需要对其进行调整，以便它从我的 Excel 文件中获取数据，在该文件中我有所有需要更改的单词/短语。
有2个类模块和1个标准模块。但在这篇文章的最后，我还包含了更多应该做我想做的事情的代码（从 Excel 文件中获取数据），但它需要适应在我的宏中工作。问题是，我不知道如何适应它。换句话说：我不知道需要在模块中替换什么才能使其工作。
另外，我相信我的 Excel 文件需要简单。A 列旧词组// B 列新词组。就这样可以正常工作吗？
这是我拥有的一切（单独）：
我被告知将其命名为“clsTerm”并粘贴以下代码：
Option Explicit
Private English As String
Private Hebrew As String
Private FNT As String
Property Let EnglishTerm(strVal As String)
English = strVal
End Property
Property Get EnglishTerm() As String
EnglishTerm = English
End Property
Property Let HebrewTerm(strVal As String)
Hebrew = strVal
End Property
Property Get HebrewTerm() As String
HebrewTerm = Hebrew
End Property
Property Let FootnoteText(strVal As String)
FNT = strVal
End Property
Property Get FootnoteText() As String
FootnoteText = FNT
End Property
第二类模块我被告知将其命名为“clsTerms”并粘贴以下代码：
Option Explicit
Private colTerms As Collection
Private lngCount As Long
Property Get Items() As Collection
Set Items = colTerms
End Property
Property Set Items(oCol As Collection)
Set colTerms = oCol
End Property
Property Get Count() As Long
If Not colTerms Is Nothing Then
Count = colTerms.Count
Else
Count = 0
End If
End Property
然后我被告知创建一个标准模块并将其命名为“我喜欢的任何东西”并粘贴以下代码：
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
Set clsTL.Items = DefinedTerms
Set m_oCol1 = New Collection
For lngIndex = 1 To clsTL.Count
'Replace each defined English word with it Hebrew equivelent.
ReplaceWords clsTL.Items(lngIndex).EnglishTerm, clsTL.Items(lngIndex).HebrewTerm
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).HebrewTerm, clsTL.Items(lngIndex).FootnoteText
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.EnglishTerm = arrEng(lngIndex)
Term.HebrewTerm = arrHeb(lngIndex)
Term.FootnoteText = arrEng(lngIndex) & ":" & arrHeb(lngIndex)
oCol.Add Term, Term.EnglishTerm
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
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
最后，这是我需要适应宏的代码，以使其从 Excel 文件中获取数据：
Sub ListFromExcel()
Dim lngIndex As Long
Dim arrWords As Variant
'Find words in column 1, Replace words in column 2
arrWords = GetListArray(You file path and name)
For lngIndex = 2 To UBound(arrWords, 1)
Debug.Print arrWords(lngIndex, 1)
Debug.Print arrWords(lngIndex, 2)
Next
End Sub
Function GetListArray(ByRef strFileName As String) As Variant
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim bAppStart As Boolean
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
bAppStart = True
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlbook = xlapp.Workbooks.Open(FileName:=strFileName)
Set xlsheet = xlbook.Worksheets(1)
GetListArray = xlsheet.Range("A1").CurrentRegion.Value
xlbook.Close
If bAppStart = True Then xlapp.Quit
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing
lbl_Exit:
Exit Function
End Function