我正在使用当前从外部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
答案 0 :(得分: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列中所有内容的位置。然后,让您定义要输出脚注的方式。在这个例子中,我正在读取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列中的任何内容,并且在类中完成连接,它应该在那里。
我没有保存上一个问题的文件,因此某些变量和属性名称可能已更改。希望很清楚,你可以适应它。