Find cell content and replace the second occurrence - excel

Question

'Im catching keywords (string) from an excel file and searching for them in a word doc. When found the string in the doc file is replaced with a specific content from an offset cell.This works for me .Some of the cells have multiple texts separated with semicolon ";".Each text must replace an occurrence of the found keyword in the doc file: for example if a cell contains 3 strings separated with a semicolon ,the first string should replace the first occurrence of the keyword in the doc file,the second one the second occurrence and the third one the third occurrence. I couldn't get a correct result. Below is the code:
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
I hope someone could help me to solve the problem.

Answer 1

The parameter you pass in 'ProdType' isn't used in the code you have published.
I've updated the code you published and it compiles, but obviously I can't run it because I don't have your worksheet and documents.
But it will help point you in the right direction
A key thing to note is how the search and replace operations have been split out from your main loop. This make the code much easier to follow.
Good luck with your endeavors.
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
Edited to update the WordFIndAndReplace sub