I am trying to excecute a VBA macro from excel to remove a row in a word document if a string is present.
For i = startItem To endItem
Dim msWord As Object
Set msWord = CreateObject("Word.Application")
With msWord
.Visible = TRUE
.Documents.Open getSetting("PTC TEMPLATE") 'path of the template in msword format
.Activate
'Remove TEST ROW
'LOOP TEST TO REMOVE
Dim DirArray As Variant
DirArray = ThisWorkbook.Sheets("valveList").ListObjects("valveList").HeaderRowRange.value
For Each element In DirArray
If element Like "*TEST*" Then
Debug.Print element & "--> " & Range("valveList[" & element & "]")(i).value
If Range("valveList[" & element & "]")(i).value = "NO" Then
.ActiveDocument.Select
With .Selection.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Range("valveList[" & element & "]")(i).value 'Find all strings in col A
.Forward = TRUE
.Wrap = wdFindStop
.MatchCase = FALSE
.MatchWholeWord = FALSE
.Execute
If .Found = TRUE Then
.Selection.Rows.Delete
End If
End With
End If
End If
Next element
'End REMOVE TEST ROW
Here I have the problem that I dont know how to refer to the found string and delete the row of the table the string belongs to.
I'm not very familiar with VBA, if someone can revise my code and explain how to solve this problem I'll be thankful
There are numerous problems with your code, including repeatedly starting Word and opening a new copy of the document you're modifying, employing Word constants with late binding, and the use of unqualified Range references. Try something along the lines of:
Sub Demo()
Dim msWord As Object, wdDoc As Object, xlSht As Worksheet, DirArray As Variant
Set xlSht = ThisWorkbook.Sheets("valveList")
DirArray = xlSht.ListObjects("valveList").HeaderRowRange.Value
Set msWord = CreateObject("Word.Application")
With msWord
.Visible = True
.ScreenUpdating = False
Set wdDoc = .Documents.Open(GetSetting("PTC TEMPLATE")) 'path of the template in msword format
For i = startItem To endItem
For Each element In DirArray
If element Like "*TEST*" Then
If xlSht.Range("valveList[" & element & "]")(i).Value = "NO" Then
With wdDoc.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = xlSht.Range("valveList[" & element & "]")(i).Text 'Find all strings in col A
.Forward = True
.Wrap = 0 'wdFindStop
.MatchCase = False
.MatchWholeWord = False
End With
Do While .Find.Execute
If .Information(12) = True Then 'wdWithInTable
.Rows(1).Delete
End If
.Collapse 0 'wdCollapseEnd
Loop
End With
End If
End If
Next element
Next i
.ScreenUpdating = True
End With
End Sub
Related
I need to use Word Macro for automatically proofreading the documents. I have an excel file, filled in with all the wrong spelling words, and after I installed the macro to Microsoft Word, it took several minutes to finish the spelling checking for just 1 page of the Word Document.
Can I use .txt to replace the excel in order to make it faster? Or what should I improve? Below please find the code for the Macro:
Attribute VB_Name = "PR"
Option Explicit
Sub PR()
Dim Path As String
Dim objExcel As Object
Dim iCount As Integer
Dim VChar As String
Dim OChar As String
Options.AutoFormatAsYouTypeReplaceQuotes = True
Path = "D:\Macro\rplPR.xlsx"
'Highlight variant characters
With ActiveDocument
.TrackRevisions = False
.ShowRevisions = False
End With
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open Path
For iCount = 2 To 2500
Selection.HomeKey Unit:=wdStory
VChar = objExcel.ActiveWorkbook.Sheets(1).Cells(iCount, 1)
If Len(VChar) = 0 Then Exit For
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.Text = VChar
.Replacement.Text = "^&"
.Execute Replace:=wdReplaceAll
End With
Next
objExcel.ActiveWorkbook.Close
objExcel.Quit
End Sub
Move these lines up to above the For statement. You are setting them 2,499 times and you only need to do it once.
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Highlight = True
.Text = VChar
.Replacement.Text = "^&"
So each dot is a function call. There are 5 needless ones done 2498 times which is 12,490 function calls.
Function calls, while essential, are slow compared to other operations as there is a lot of setup.
If you didn't use with that would be an extra 12,490 function calls as well for a total of 24,980 sloww needless function calls.
Try the following. Do note that there is necessarily some overhead involved in starting Excel (if not already running), as well as processing the workbook. Hence, even a single-page document will encounter the same overhead there as a 100-page document.
Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList As String, xlRList As String, i As Long
StrWkBkNm = "D:\Macro\rplPR.xlsx": StrWkSht = "Sheet1"
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
On Error GoTo 0
With xlApp
'Hide our Excel session
.Visible = False
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
.Quit: Set xlApp = Nothing: Exit Sub
End If
' Process the workbook.
With xlWkBk
With .Worksheets(StrWkSht)
' Find the last-used row in column A.
iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
' Capture the F/R data.
For i = 1 To iDataRow
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList = xlFList & "|" & Trim(.Range("A" & i))
xlRList = xlRList & "|" & Trim(.Range("B" & i))
End If
Next
End With
.Close False
End With
.Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
'Process each word from the F/R List
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
For i = 1 To UBound(Split(xlFList, "|"))
.Text = Split(xlFList, "|")(i)
.Replacement.Text = Split(xlRList, "|")(i)
.Execute Replace:=wdReplaceAll
Next
End With
Application.ScreenUpdating = True
End Sub
I´m trying to find and replace multiple sentences from different word files from an specific folder. The words that I´m trying to change are on two columns in excel (Columns B and C)
The changes are been done correctly, but for some reason the words are not erased completly and the change happens twice. This is due to the trackchanges that needs to be activated due to the requirements of this automation.
Right now it does the first change, but then the word appears as if it wasn´t changed, so it does the change again with the new word.
This is the code:
Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Dim Wrd As New Word.Application
Dim Dict As Object
Dim RefList As Range, RefElem As Range
Dim Key
Dim wrdRng As Range
Dim WDoc As Document
Wrd.Visible = True
Set WDoc = Wrd.Documents.Open(filename:=sFileName, OpenAndRepair:=True) 'Modify as necessary.
Debug.Print sFileName
'Assigns the columns that is going to have the original texts that need to be changed
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Reemplazos").Range("B2:B50") 'Modify as necessary.
'Selects the column that´s one column to the right of the reference column
With Dict
For Each RefElem In RefList
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
.Add RefElem.Value, RefElem.Offset(0, 1).Value
Debug.Print RefElem
End If
Next RefElem
End With
' Activar control de cambios en cada documento
With WDoc:
.TrackRevisions = True
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
End With
'Assigns the conditions and loops through each text to replace it
For Each Key In Dict
With WDoc.Content.FIND
Application.ScreenUpdating = False
Debug.Print Key
.ClearFormatting
.Replacement.ClearFormatting
.Text = Key
.Font.Color = vbBlack
.Replacement.Text = Dict(Key)
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWildcards = False
.MatchSoundsLike = False
.Execute Replace:=2
End With
Next Key
'Saves, Closes and quits the words.
WDoc.SaveAs NewNewWordName(sFileName)
WDoc.Close
Wrd.Quit
I though about getting a requirement of only changing the words when they are on the color black, because the trackchanges leaves the sentence with a color red. But I do not know how to do it.
In cases like this, you need to use something other than Replace for the replacement. For example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "AFC admin"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While .Find.Execute
With .Duplicate
If .Words.Last.Next = "(" Then
.MoveEndUntil ")", wdForward
.End = .End + 1
If Split(.Text, " ")(2) = "(ORG)" Then .Text = "REVISE"
Else
.Text = "DEBUG"
End If
End With
.Collapse wdCollapseEnd
Loop
End With
Application.ScreenUpdating = True
End Sub
Alternatively, you might do Find/Replace as:
AFC admin ----- DEBUG
then
DEBUG (ORG) ----- REVISE
I found a solution to this problem:
Dim Wbk As Workbook: Set Wbk = ThisWorkbook
Dim Wrd As New Word.Application
Dim Dict As Object
Dim RefList As Range, RefElem As Range
Dim Key
Dim wrdRng As Range
Dim WDoc As Document
Dim intParaCount
Dim objParagraph
Dim Wordd As Object
Wrd.Visible = True
Set WDoc = Wrd.Documents.Open(filename:=sFileName, OpenAndRepair:=True) 'Modify as necessary.
With WDoc:
.TrackRevisions = True
WDoc.ActiveWindow.View.MarkupMode = wdBalloonRevisions
End With
Set Dict = CreateObject("Scripting.Dictionary")
Set RefList = Wbk.Sheets("Reemplazos").Range("B2:B50") 'Modify as necessary.
With Dict
For Each RefElem In RefList
If Not .Exists(RefElem) And Not IsEmpty(RefElem) Then
.Add RefElem.Value, RefElem.Offset(0, 1).Value
''Debug.Print RefElem
End If
Next RefElem
End With
For Each Key In Dict
With WDoc.Content.FIND
Debug.Print Key
.Execute MatchAllWordForms:=False
.Execute Forward:=True
.Execute Wrap:=wdFindAsk
.Execute Format:=False
.Execute MatchCase:=False
.Execute MatchWildcards:=False
.Execute MatchSoundsLike:=False
.Execute wdReplaceAll
.Font.Color = wdColorAutomatic
.Execute FindText:=Key, ReplaceWith:=Dict(Key), Replace:=2
End With
Set objParagraph = WDoc.Content
objParagraph.FIND.Text = Key
Debug.Print Key
Do
objParagraph.FIND.Execute
If objParagraph.FIND.Found Then
objParagraph.Font.Color = RGB(0, 0, 1)
End If
Loop While objParagraph.FIND.Found
Next Key
WDoc.SaveAs NewNewWordName(sFileName)
WDoc.Close
Wrd.Quit
What this process does is change the color of each word once is changed.
I have assigned a color condition so that it only changes words with the color automatic:
.Font.Color = wdColorAutomatic
Once is changed, the word inside track changes are changed to another color, very similar but that are different:
objParagraph.Font.Color = RGB(0, 0, 1)
This way it only changes each word once. The only problem with this solution is that you need to assign all the words to the automatic color or the color you decide to give it.
I hope this helps anyone that found this or a similar problem.
FYI this code works for people that need to change multiple words that appear in columns in excel. I found lots of people with this problem. So check the code and it might help you.
I have a VBA code that copies data from MS Word documents in a folder and pastes them into an MS Excel file. The folder contains about over 2000 MS word files. The code opens each word file in the folder and looks for two key words, lets call them "FindWord1" and "FindWord2", then copies all the data (including text) that is located between these two keywords from this word file and pastes it into a Excel worksheet. Then moves on to the next Word file in the folder.
Some of these 2000 word documents are missing the two keywords. If the code does not find the key words (either "Findword1" or "Findword2") it returns an error. So only the word documents opened before this error are copied and pasted. Is there a way to log the files names of the word documents that are missing the keywords, skip them and move on to the next file in the folder.
The code runs fine as is, but I have to manually go and remove the file from the folder for it to go to the next file which is taking a lot of time. I would appreciate any help here.
Thanks,
N
'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.
Application.ScreenUpdating = False
'Objects
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim strFolder As String, strFile As String, lRow As Long
Dim WkSht As Worksheet: Set WkSht = ActiveSheet
'Folder Location
strFolder = "C:\Users\Folder\"
strFile = Dir(strFolder & "*.docx", vbNormal)
'Loop Start
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
lRow = WkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
With wdDoc
' Text you want to search
Dim FindWord1, FindWord2 As String
Dim result As String
FindWord1 = "Keyword1"
FindWord2 = "Keyword2"
'Style
mystyle = ""
'Defines selection for Word's find function
wdDoc.SelectAllEditableRanges
' Move your cursor to the start of the document
wdDoc.ActiveWindow.Selection.HomeKey unit:=wdStory
'Find Functionality in MS Word
With wdDoc.ActiveWindow.Selection.Find
.Text = FindWord1
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
If mystyle <> "" Then
.Style = mystyle
End If
If .Execute = False Then
MsgBox "'Text' not found.", vbExclamation
Exit Sub
End If
' Locate after the ending paragraph mark (beginning of the next paragraph)
' wdDoc.ActiveWindow.Selection.Collapse Direction:=wdCollapseEnd
' Starting character position of a selection
lngStart = wdDoc.ActiveWindow.Selection.End 'Set Selection.Start to include searched word
.Text = FindWord2
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
'.Style = mystyle
If .Execute = False Then
MsgBox "'Text2' not found.", vbExclamation
Exit Sub
End If
lngEnd = wdDoc.ActiveWindow.Selection.Start 'Set Selection.End to include searched word
End With
'Copy Selection
wdDoc.Range(lngStart, lngEnd).Copy
WkSht.Paste WkSht.Range("C" & lRow)
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Please remember to declare all variables, add Option Explicit at the top of your module to help you enforce this.
You might know this already but Dim FindWord1, FindWord2 As String will declare FindWord1 as Variant, you have to declare the variable type for each variable one by one i.e. Dim FindWord1 As String, FindWord2 As String.
What is mysetyle for? It's not being used but I have left it there anyway, please delete if there is no use for it.
Try below code, if the Word document does not contain both keywords then it will prompt a MsgBox and Debug.Print to the immediate window, modify to your needs:
Private Sub Test()
'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.
Application.ScreenUpdating = False
'Objects
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim lRow As Long
Dim WkSht As Worksheet
Set WkSht = ActiveSheet
Const colPaste As Long = 3 'Column C
'Search String
Const FindWord1 As String = "Keyword1"
Const FindWord2 As String = "Keyword2"
'Folder Location
'Const strFolder As String = "C:\Users\Folder\"
Dim strFile As String
strFile = Dir(strFolder & "*.docx", vbNormal)
'Loop Start
While strFile <> vbNullString
If wdApp Is Nothing Then Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
lRow = WkSht.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
'Style
mystyle = vbNullString
Dim firstRng As Word.Range
Set firstRng = wdDoc.Range.Duplicate
'Find Functionality in MS Word
With firstRng.Find
.Text = FindWord1
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If firstRng.Find.Found Then
Dim secondRng As Word.Range
Set secondRng = wdDoc.Range(firstRng.End, wdDoc.Range.End).Duplicate
With secondRng.Find
.Text = FindWord2
.Replacement.Text = ""
.Forward = True
.Wrap = 1
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
If secondRng.Find.Found Then
'Found both keywords, copy to worksheet
Dim copyRng As Word.Range
Set copyRng = wdDoc.Range(firstRng.Start, secondRng.End).Duplicate
copyRng.Copy
'WkSht.Cells(lRow, colPaste).Paste
WkSht.Paste WkSht.Range("C" & lRow)
Else
'Error - second word not found~ abort and move on to next file
MsgBox "Second word not found" & vbNewLine & _
strFolder & strFile
Debug.Print "Second word not found: " & strFolder & strFile
End If
Else
'Error - first word not found~ abort and move on to next file
MsgBox "First word not found" & vbNewLine & _
strFolder & strFile
Debug.Print "First word not found: " & strFolder & strFile
End If
Set firstRng = Nothing
Set secondRng = Nothing
Set copyRng = Nothing
wdDoc.Close 0
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Do you have lngStart and lngEnd defined somewhere? Maybe Dim them and assign 0 to both right after opening the next word doc, and then check if they are not equal to
0 before the copy to excel part. Don't have any considerable experience for Word VBA, sorry if not applicable.
I found the macro in this link and it works great, https://wordribbon.tips.net/T001173_Highlight_Words_from_a_Word_List.html:
It highlights words from another Word document in the current document. I need to see if it can work for phrases and not just single words. It's okay if I need to put identifying markers before and after the phase, like double brackets or something [[ ... ]], for example. Is this possible and how would it be placed in this macro?
If the list could be from an Excel document, that would be even better but not a deal breaker.
Examples are:
Tony the Tiger (but only when the macro finds that entire phrase. As it works now, it would find all instances of all three words independently and the 'the' would of course be problematic. Another one would be '17th c.' In this case, it finds every c and every dot as well. It would be ideal to find only the entire phrase.
The code in the link you posted is very inefficient. For a way more efficient approach, see:
https://www.msofficeforums.com/word-vba/23196-need-help-creating-macro.html
A simple solution that doesn't require another file is:
Sub BulkHighlighter()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String, HiLt As Long
HiLt = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdBrightGreen
StrFnd = InputBox("Insert your 'Find' terms with | delimiters, for example:" & vbCr & "the quick brown fox|jumped over|the lazy dog")
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Replacement.Highlight = True
.Replacement.Text = "^&"
For i = 0 To UBound(Split(StrFnd, "|"))
.Text = Split(StrFnd, "|")(i)
.Execute Replace:=wdReplaceAll
Next
End With
Options.DefaultHighlightColorIndex = HiLt
Application.ScreenUpdating = True
End Sub
Alternatively, if the list of strings to be highlighted is fixed:
Sub BulkHighlighter()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String, HiLt As Long
HiLt = Options.DefaultHighlightColorIndex
Options.DefaultHighlightColorIndex = wdBrightGreen
StrFnd = "the quick brown fox|jumped over|the lazy dog"
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Replacement.Highlight = True
.Replacement.Text = "^&"
For i = 0 To UBound(Split(StrFnd, "|"))
.Text = Split(StrFnd, "|")(i)
.Execute Replace:=wdReplaceAll
Next
End With
Options.DefaultHighlightColorIndex = HiLt
Application.ScreenUpdating = True
End Sub
If you're wedded to using an Excel file, try:
Sub BulkHighlighter()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String
Dim StrWkSht As String, xlFList As String, i As Long
'Identify the WorkBook and WorkSheet
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xlsx"
StrWkSht = "Sheet1"
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
On Error GoTo 0
With xlApp
'Hide our Excel session
.Visible = False
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
.Quit: Set xlApp = Nothing: Exit Sub
End If
' Process the workbook.
With xlWkBk
With .Worksheets(StrWkSht)
' Capture the F/R data.
For i = 1 To .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
' Skip over empty fields to preserve the underlying cell contents.
If Trim(.Range("A" & i)) <> vbNullString Then
xlFList = xlFList & "|" & Trim(.Range("A" & i))
End If
Next
End With
.Close False
End With
.Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
'Process each word from the F/R List
With ActiveDocument.Range.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindContinue
.Replacement.Text = "^&"
For i = 1 To UBound(Split(xlFList, "|"))
.Text = Split(xlFList, "|")(i)
.Execute Replace:=wdReplaceAll
Next
End With
Application.ScreenUpdating = True
End Sub
For processing multiple documents in the same folder using an Excel workbook, see:
https://www.msofficeforums.com/70404-post4.html
Note that the code in this last link shows how to process content in headers, footers, etc. also.
'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.
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