Параметр, который вы передаете в '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 sub