我从excel文件中捕获关键字（字符串）并在word doc中搜索它们。当发现doc文件中的字符串被替换为offseted excel单元格中的特定内容时。这对我有用。一些单元格有多个文本用分号“;”分隔。每个文本必须替换找到的关键字的出现doc文件：例如，如果一个单元格包含3个用分号分隔的字符串，则第一个字符串应该替换doc文件中关键字的第一个出现，第二个字符串替换第二个出现，第三个出现第三个出现。我无法得到正确的结果。以下是代码：
Option Explicit
Public Sub copy_file(source, destination)
Dim FsyObjekt As Object
Set FsyObjekt = CreateObject("Scripting.FileSystemObject")
FsyObjekt.CopyFile source, destination
End Sub
Public Sub WordFindAndReplace(Index_offset, ProdType)
Dim ws As Worksheet, msWord As Object, itm As Range
Dim spl() As String, NbLines, Index, Occurences As Integer
Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")
Index = 0
With msWord
.Visible = True
.Documents.Open Filename:=ThisWorkbook.Path & "\Template.docx"
.Activate
With .ActiveDocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
For Each itm In ws.Range("A6:A221")
.Text = itm.Text
If IsEmpty(itm.Offset(, Index_offset)) Then
.Replacement.Text = " "
Else
If InStr(1, itm.Offset(, Index_offset), ";", 1) > 0 Then
.Forward = True
.Wrap = wdFindContinue
.Format = False
.Execute Replace:=wdReplaceOne
spl = Split((itm.Offset(, Index_offset)), ";")
NbLines = UBound(spl) - LBound(spl) + 1
Index = 0
If Index <> NbLines - 1 Then
.Replacement.Text = spl(Index)
Index = Index + 1
End If
Else
.Replacement.Text = itm.Offset(, Index_offset).Text
.Execute Replace:=wdReplaceAll
End If
End If
.MatchCase = False
.MatchWholeWord = False
.Replacement.Highlight = False
Next itm
End With
.Quit SaveChanges:=True
End With
End Sub
我希望有人能帮我解决问题。
您在'ProdType'中传递的参数未在您发布的代码中使用。
我已更新您发布的代码并进行编译，但显然我无法运行它，因为我没有您的工作表和文档。
但它会帮助您指明正确的方向
需要注意的一个关键事项是如何从主循环中分离出搜索和替换操作。这使代码更容易遵循。
祝你好运。祝你好运。
Public Sub WordFindAndReplace(Index_Offset As Long, ProdType As String) ' ProdType is not used in the code you published
Const blankString As String = " " ' might bebetter using vbnullstring instead of " "
Dim ws As Excel.Worksheet ' Requires that Tools.References.Microsoft Excel X.XX Object Library is ticked
Dim msWord As Word.Application ' Requires that Tools.References.Microsoft Word X.XX Object Library is ticked
Dim spl() As String ' changed back to string as we can also iterate over a string array
Dim mySpl As Variant ' the variable in a for each has to be an object or variant
Dim myIndex As Long ' Was implicitly declared as Variant
Dim myDoc As Word.Document ' Better to get a specific reference to a document rather than use activedocument
Dim myOffsetString As String
Dim myFindString As String '
Dim myCells() As Variant
Dim myOffsetCells As Variant
Dim myOffsetRange As Variant
Set ws = ActiveSheet
Set msWord = New Word.Application ' changed from late to early binding as early binding gives intelisense for word objects
'Index = 0 not needed any more
With msWord
.Visible = True ' Not necessary if you just want to process some actions on a document but helpful when developing
Set myDoc = .Documents.Open(FileName:=ThisWorkbook.Path & "\Template.docx") 'changed to function form due to assignment to myDoc
'.Activate ' Not needed when working with a direct reference to a document
End With
' Bring the cells in the target column and the offset column into vba arrays
' an idiosyncracy when pullin in a column is we get a two dimensional array
myCells = ws.Range("A6:A221").Value2
myOffsetRange = Replace("A6:A221", "A", Chr$(Asc("A") + Index_Offset))
myOffsetCells = ws.Range(myOffsetRange).Value2
' As we are using two arrays we can't now do for each so back to using an index
' Another idiosyncracy is that the arrays start at 1 and not 0
For myIndex = 1 To UBound(myCells)
myOffsetString = CStr(myOffsetCells(myIndex, 1))
myFindString = CStr(myCells(myIndex, 1))
If Len(myOffsetString) = 0 Then 'quicker than comparing against vbnullstring
replaceText_ReplaceAll myDoc, myFindString, blankString
Else
' The offset cell contains a string (because it is not empty)
' It doesn't matter if there is no ';' in the string
' split will just produce an array with one cell
spl = Split(myOffsetString, ";")
If UBound(spl) = 0 Then
' Only one item present
replaceText_ReplaceAll myDoc, myFindString, Trim(CStr(mySpl))
Else
' more than one item present
For Each mySpl In spl
replaceText_ReplaceSingleInstance myDoc, myFindString, Trim(CStr(mySpl))
Next
' now replace any excess ocurrences of myFIndString
replaceText_ReplaceAll myDoc, myFindString, blankString
End If
End If
Next
myDoc.Close savechanges:=True
msWord.Quit
Set msWord = Nothing
End Sub
Sub replaceText_ReplaceAll(this_document As Word.Document, findText As String, replaceText As String)
With this_document.StoryRanges(wdMainTextStory).Find
.ClearFormatting
.Format = False
.Wrap = wdFindStop
.Text = findText
.Replacement.Text = replaceText
.Forward = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
Sub replaceText_ReplaceSingleInstance(this_document As Word.Document, findText As String, replaceText As String)
With this_document.StoryRanges(wdMainTextStory).Find
.ClearFormatting
.Format = False
.Wrap = wdFindContinue
.Text = findText
.Replacement.Text = replaceText
.Forward = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub
编辑更新WordFIndAndReplace子