I cannot seem to get the VBA code that finds and replaces words in the word document to work.
I can find the words in the word document manually, but the vba code has no effect.
Hello,
I am trying to create a custom form in word through an excel input sheet. My issue is that the code that finds and replaces the words in the word document gets ignored in vba even while the word document is open (I can manually find the words in the document). Opening the word file through VBA is not an issue.
Could someone please show me how to find and replace words in my word document?
As displayed in the code below, I alreay tried the "With.WordDoc.Content.find" method without success.
Below I added the code to find one of the words
Thank you!
Sub CreateWordDocuments()
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim WordDoc, Wordapp As Object
Dim RownumDocLoc As Integer
Dim inputsheet As Worksheet
Set inputsheet = ThisWorkbook.Sheets("Input")
Dim templatesheet As Worksheet
Set templatesheet = ThisWorkbook.Sheets("Templates")
inputsheet.Activate
templaterow = Application.Match("Template:", Columns("B:B"), 0)
If inputsheet.Cells(templaterow, 4) = "" Then
MsgBox "Please complete the template criteria", , "No template selected"
inputsheet.Cells(1, 1).Select
Exit Sub
End If
TemplName = inputsheet.Cells(templaterow, 4)
templatesheet.Activate
RownumDocLoc = Application.Match(TemplName, Columns("F:F"), 0)
DocLoc = templatesheet.Cells(RownumDocLoc, 7) & "\" & TemplName
'Open Word Template
On Error Resume Next
Set Wordapp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set Wordapp = CreateObject("Word.Application")
Wordapp.Visible = True
End If
'Open Template
Set WordDoc = Wordapp.documents.Open(FileName:=DocLoc, ReadOnly:=False)
With WordDoc.Content.Find
.Text = "samplestring"
.Replacement.Text = "adjustedstring"
.wrap = wdFindContinue
.Execute Replace:=wdReplaceall
End With
End Sub
I would expect the string "samplestring" to be adjusted to "adjustedstring" in the word file. However nothing happens when the code runs (no errors).
Related
I have a macro in an Excel workbook that currently does the following:
Create a data.csv file with data in the first two rows (for a mail merge)
Pull a template of a selected Word document and make the data.csv file the source for the mail merge
If the user chooses, it finishes the merge for the document
If the user chooses, it opens the document when the macro is complete. If they don't choose to open, the word documents all close.
I've been running into a couple major issues:
The macro only seems to run smoothly if Word is entirely closed beforehand. My current workaround is a popup message if Word is open, telling the user to close word, but this is not ideal because it disrupts flow for some users who may have several instances of Word open.
The macro has been running slowly, especially for some of the document templates that have thousands of merge fields pre-entered in the template. It sometimes take longer than a minute, and sometimes completely freezes.
Would the macro would run more smoothly if I have the Excel VBA open the Word template and have most of the code for setting up and finishing the mail merge in Word VBA? I'm much less familiar with Word VBA - can anyone help me with bringing over my code to word (but still initiated by Excel)? Also, if you can figure out why the macro struggles when Word is already open, I'd greatly appreciate it.
I didn't include the entire code for proprietary reasons, but please let me know if there's something else you need to see.
Thank you!!
Sub Mail_Merge_Dynamic()
Dim mergeFile, tempFilePath As String
Dim WordDoc, WordApp As Object
Dim tempPath, mergePath, finalPath, curDir As String
Dim mergeFilePath, finalFilePath As String
Dim dataPath, FileNameCell, PrincCertCell, MMPrefix As String
Dim FileCount As Integer
Dim Close_Choice, ActiveWindow As String
Dim WarningMsg, WarningMsg2 As String
Dim NotFound, Overwrite1, Overwrite2 As Boolean
Dim oBook As Workbook
'Update csv file for Data Merge
narrative_merge
Call WarpSpeed_On
Sheets("Navigation").Select
Range("Merge_File_1").Select
Set WordApp = CreateObject("Word.Application")
'//////////////////////////////MAIL MERGE MACRO\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'Set up Mail Merge Documents from Template Folder based on selections on Navigation tab
For i = 1 To FileCount
FileNameCell = "Merge_File_" & i
If Range(FileNameCell) = "" Then
Else
mergeFile = Range(FileNameCell)
tempFilePath = tempPath & mergeFile
mergeFilePath = mergePath & "MM_" & mergeFile
finalFilePath = finalPath & mergeFile
'Activate Mail Merge
If Range("MM_Activate") = 0 Then
Else
Set WordDoc = WordApp.Documents.Open(tempFilePath)
With WordDoc.MailMerge
.MainDocumentType = wdFormLetters
'Set up the mail merge data source
dataPath = curDir & "\data.csv"
.OpenDataSource Name:=dataPath
'Show values in the mail merge fields
.ViewMailMergeFieldCodes = wdToggle
End With
'WordDoc.ShowFieldCodes = False
'WordDoc.MailMerge.ViewMailMergeFieldCodes = False
WordDoc.SaveAs FileName:=mergeFilePath
End If
' Finish mail merge
If Range("MM_Finish") = 0 Then
Else
With WordDoc.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
.Execute Pause:=False
End With
WordDoc.Application.ActiveDocument.SaveAs finalFilePath
End If
End If
Next i
Call CloseWordDocuments
'Make word visible if an Open command has been selected
If Range("MM_Open_Merge") = 1 Or Range("MM_Open_Doc") = 1 Then
curDir = ThisWorkbook.Path
Set WordApp = CreateObject("Word.Application")
For i = 1 To FileCount
FileNameCell = "Merge_File_" & i
If Range(FileNameCell) = "" Then
Else
mergeFile = Range(FileNameCell)
mergeFilePath = curDir & "\Merge-Active Forms\" & "MM_" & mergeFile
finalFilePath = curDir & "\Merge-Complete Forms\" & mergeFile
If Range("MM_Open_Merge") = 1 Then
Set WordDoc = WordApp.Documents.Open(mergeFilePath)
End If
If Range("MM_Open_Doc") = 1 Then
Set WordDoc = WordApp.Documents.Open(finalFilePath)
End If
End If
Next i
WordApp.Visible = True
'Windows(mergeFile).Activate
End If
GoTo Reset
Reset:
Call WarpSpeed_Off
End Sub
Sub WarpSpeed_On_Calcs_Off()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Turn off display alerts
Application.DisplayAlerts = False
End Sub
Sub WarpSpeed_On()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
' Turn off display alerts
Application.DisplayAlerts = False
End Sub
Sub WarpSpeed_Off()
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Instead of:
Set WordApp = CreateObject("Word.Application")
this will open Word if it is not already open:
Set WordApp = GetObject(, "Word.Application")
Edit#1
In VBA you may do something like:
On Error GoTo CreateObj
' Is Word application already running ?
Set WordApp = GetObject(, "Word.Application")
GoTo gotApp
CreateObj:
' Not running, create first instance:
Set WordApp = CreateObject("Word.Application")
gotApp:
On Error GoTo 0 ' disable error handling
' continue
....
....
I have a folder with a few hundred-word documents. I want to be able to replace the words ORG NAME by clicking a macro, filling in an input box and letting it iterate. There are thousands of instances of ORG NAME across these documents and this process needs to happen a few dozen times a year.
We've got some challenges with trust centre policies in place that can't be changed so the macro needs to be done via excel.
The below was sort of working as word macro although it was crashing a lot, I moved it over to excel and now I'm getting the error: Named argument not found against macroname:
I can't find any similar questions that aren't solved by correcting spelling.
I'm also open to better solutions if they exist, this has been my first attempt so far.
Sub Button1_Click()
Dim xFileDialog As FileDialog, GetStr(1 To 300) As String '300 files is the maximum applying this code
Dim xFindStr As String
Dim xReplaceStr As String
Dim xDoc As Object
On Error Resume Next
Set xFileDialog = Application.FileDialog(msoFileDialogFilePicker)
With xFileDialog
.Filters.Clear
.Filters.Add "All WORD File ", "*.docx", 1
.AllowMultiSelect = True
i = 1
If .Show = -1 Then
For Each stiSelectedItem In .SelectedItems
GetStr(i) = stiSelectedItem
i = i + 1
Next
i = i - 1
End If
Application.ScreenUpdating = False
xFindStr = "ORG NAME"
xReplaceStr = InputBox("Enter the name of the organisation:", "Document Updater for Word", xReplaceStr)
For j = 1 To i Step 1
Set xDoc = Documents.Open(Filename:=GetStr(j), Visible:=True)
Windows(GetStr(j)).Activate
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = xFindStr 'Find What
.Replacement.Text = xReplaceStr 'Replace With
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Application.Run macroname:="NEWMACROS"
ActiveDocument.Save
ActiveWindow.Close
Next
Application.ScreenUpdating = True
End With
MsgBox "Operation end, please view", vbInformation
End Sub
See this page by Ibby on the Word MVP website.
How to Find & ReplaceAll on a batch of documents in the same folder
The following code, if stored in a Global template, will perform a
Find & ReplaceAll in all of the documents in a specified folder. The
FindReplace dialog is displayed for the first document only. The user
sets the parameters in the dialog and presses Replace All and then
Close. The user is then asked whether to process all of the files in
the specified directory – if Yes, the rest of the files are processed
with the settings as entered in the original FindReplace dialog.
Option Explicit
Public Sub BatchReplaceAll()
Dim FirstLoop As Boolean
Dim myFile As String
Dim PathToUse As String
Dim myDoc As Document
Dim Response As Long
PathToUse = "C:\Test\"
'Error handler to handle error generated whenever
'the FindReplace dialog is closed
On Error Resume Next
'Close all open documents before beginning
Documents.Close SaveChanges:=wdPromptToSaveChanges
'Boolean expression to test whether first loop
'This is used so that the FindReplace dialog will
'only be displayed for the first document
FirstLoop = True
'Set the directory and type of file to batch process
myFile = Dir$(PathToUse & "*.doc")
While myFile <> ""
'Open document
Set myDoc = Documents.Open(PathToUse & myFile)
If FirstLoop Then
'Display dialog on first loop only
Dialogs(wdDialogEditReplace).Show
FirstLoop = False
Response = MsgBox("Do you want to process " & _
"the rest of the files in this folder", vbYesNo)
If Response = vbNo Then Exit Sub
Else
'On subsequent loops (files), a ReplaceAll is
'executed with the original settings and without
'displaying the dialog box again
With Dialogs(wdDialogEditReplace)
.ReplaceAll = 1
.Execute
End With
End If
'Close the modified document after saving changes
myDoc.Close SaveChanges:=wdSaveChanges
'Next file in folder
myFile = Dir$()
Wend
End Sub
That should get you started. The page has more on subfolders and password protected files.
If you need to do more than find and replace, see also utilities for batch processing documents by Greg Maxey and by Graham Mayor.
I am relatively new to VBA coding in Excel. I have adapted this VBA code for my use in order to replace all tagged text with what is in the Excel sheet. This works as intended for the main content in the word document. The only issue I have is that it is not searching/replacing text in the headers of the Word document. Does anyone have any suggestions as to editing the code to find and replace the text in the headers? I am sure it is something simple like defining the right object, but I cannot figure it out. Thank you!
Dim CustRow, CustCol, TemplRow As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp As Object
Dim WordContent, WordHeaderFooter As Word.Range
With Sheet106
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("J3").Value 'Set Template Name
DocLoc = .Range("E" & TemplRow).Value 'Word Document Filename
'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
CustRow = 4
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 16 To 180 'Move Through all Columns
TagName = .Cells(3, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol
If .Range("J1").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("Q" & CustRow).Value & _
"_" & .Range("P" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else: 'If Word
FileName = ThisWorkbook.Path & "\" & .Range("Q" & CustRow).Value _
& "_" & .Range("P" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
End With
End Sub
Tim Williams and I both recommended looking at the MVP web page by Jonathan West, Peter Hewitt, Doug Robbins and Greg Maxey. Here is a partial quotation.
This is Word code so you will need tag it to your WordDoc object instead of ActiveDocument.
The complete code to find or replace text anywhere is a bit complex.
Accordingly, let’s take it a step at a time to better illustrate the
process. In many cases the simpler code is sufficient for getting the
job done.
Step 1
The following code loops through each StoryRange in the active
document and replaces the specified .Text with .Replacement.Text:
Sub FindAndReplaceFirstStoryOfEachType()
Dim rngStory As Range
For Each rngStory In ActiveDocument.StoryRanges
With rngStory.Find
.Text = "find text"
.Replacement.Text = "I'm found"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Next rngStory
End Sub
(Note for those already familiar with VBA: whereas if you use
Selection.Find, you have to specify all of the Find and Replace
parameters, such as .Forward = True, because the settings are
otherwise taken from the Find and Replace dialog's current settings,
which are “sticky”, this is not necessary if using [Range].Find –
where the parameters use their default values if you don't specify
their values in your code).
The simple macro above has shortcomings. It only acts on the "first"
StoryRange of each of the eleven StoryTypes (i.e., the first header,
the first textbox, and so on). While a document only has one
wdMainTextStory StoryRange, it can have multiple StoryRanges in some
of the other StoryTypes. If, for example, the document contains
sections with un-linked headers and footers, or if it contains
multiple textboxes, there will be multiple StoryRanges for those
StoryTypes and the code will not act upon the second and subsequent
StoryRanges. To even further complicate matters, if your document
contains unlinked headers or footers and one of the headers or footers
are empty then VBA can have trouble "jumping" that empty header or
footer and process subsequent headers and footers.
Step 2
To make sure that the code acts on every StoryRange in each each
StoryType, you need to:
Make use of the NextStoryRange method
Employ a bit of VBA "trickery" as provided by Peter Hewett to bridge any empty unlinked headers and footers.
Public Sub FindReplaceAlmostAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
'Fix the skipped blank Header/Footer problem as provided by Peter Hewett
lngJunk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
With rngStory.Find
.Text = "find text"
.Replacement.Text = "I'm found"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
There is one remaining problem. Just like with the Find and Replace
utility, the code above can miss any text that is contained in one
StoryType/StoryRange nested in a different StoryType/StoryRange. While
this problem does not occur with a nested StoryType/StoryRange in the
wdMainTextStory StoryRange, it does occur in header and footer type
StoryRanges. An example is textbox that is located in a header or
footer.
Step 3
Fortunately Jonathan West provided a work around for the problem of
such nested StoryRanges. The work around makes use of the fact that
Textboxes and other Drawing Shapes are contained in a document’s
ShapeRange collection. We can therefore check the ShapeRange in each
of the six header and footer StoryRanges for the presence of Shapes.
If a Shape is found, we then check each Shape for the presence of the
text, and finally, if the Shape contains text we set our search range
to that Shape's .TextFrame.TextRange.
This final macro contains all of the code to find and replace text
“anywhere” in a document. A few enhancements have been added to make
it easier to apply the desired find and replace text strings.
Note: It is important to convert the code text to plain text before
you paste: if you paste directly from a web browser, spaces are
encoded as non-breaking spaces, which are not "spaces" to VBA and will
cause compile- or run-time errors. Also: Be careful of the long lines
in this code. When you paste this code into the VBA Editor, there
should be NO red visible anywhere in what you pasted. If there is,
try carefully joining the top red line with the one below it (without
deleting any visible characters.
Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim pFindTxt As String
Dim pReplaceTxt As String
Dim lngJunk As Long
Dim oShp As Shape
pFindTxt = InputBox("Enter the text that you want to find." _
, "FIND" )
If pFindTxt = "" Then
MsgBox "Cancelled by User"
Exit Sub
End If
TryAgain:
pReplaceTxt = InputBox( "Enter the replacement." , "REPLACE" )
If pReplaceTxt = "" Then
If MsgBox( "Do you just want to delete the found text?", _
vbYesNoCancel) = vbNo Then
GoTo TryAgain
ElseIf vbCancel Then
MsgBox "Cancelled by User."
Exit Sub
End If
End If
'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SearchAndReplaceInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6 , 7 , 8 , 9 , 10 , 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SearchAndReplaceInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Public Sub SearchAndReplaceInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String , ByVal strReplace As String )
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub
My goal is to find unique text in the word document "The economies of Northern Ireland " and copy three consecutive words from this document. And I have to do this from excel VBA.
The word document being searched, will be manually opened before VBA code is executed from .xlsm file.
It's going to be the only opened .docx file at the time of VBA code execution, but the file name will always be different, therefore we cannot hardcode the .docx file name nor path.
Sub Find_Price()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Dim TextToFind As String
Dim NumberToFind As String
Dim Rng As Word.Range
Application.ScreenUpdating = False
'This is the text I'm looking for in .ActiveDocument
TextToFind = "The economies of Northern Ireland "
NumberToFind = "82110907192"
'Reference already opened Word document from excel VBA console
Set WordApp = GetObject(, "Word.Application")
WordApp.Application.Visible = True
WordDoc.Select
Set Rng = WordApp.ActiveDocument.Content
'Set WordDoc = WordApp.Documents.Open(FilePath & "Form1.docx")
'Set WordDoc = WordApp.ActiveDocument 'I don't know how to finish this line :-(
'With WordApp.Content.Find.Execute.NumberToFind
With WordDoc.Content.Find.Execute.NumberToFind 'Code crashes in this line;
Rng.Find.Execute FindText:=TextToFind, Forward:=True
'what this "Forward:=True" means??
If Rng.Find.Found Then
If Rng.Information(wdWithInTable) Then
' I don't know how to write this part of the code.
' Please don't remove my question again - I've researched 16h for this info.
MsgBox "Price is " & TextToFind & " pln."
End If
Else
MsgBox "Text was not found!"
End If
End Sub
The code crashes on this line:
With WordDoc.Content.Find.Execute.NumberToFind
Most important thing for me is to:
1) perform a search on currently opened word doc, from excel vba editor,
2) find unique text = "The economies of Northern Ireland " in this word document,
3) and copy this text to a clipboard, so I could manually paste it into the cell of my choice.
Search the range.
With Rng.Find
.Text = "The economies of Northern Ireland "
.Execute
If .Found = True Then
Rng.MoveEnd wdWord, 3
Rng.Copy
Else
MsgBox "Not found"
End If
End With
If the word document is already open (and you're sure it will be open every time) then I'd just lazily declare variables.
Dim oDoc as Word.Document
Set oDoc = Word.ActiveDocument
Dim oRng as Word.Range
Set oRng = oDoc.Content
But that's my personal opinion.
I'm fairly new to VBA, trying to fill out a word template from Excel with VBA in Excel. I'm using the following code to put in the Date into a tag in the word document:
Dim Template As String
Dim WordDoc, WordApp As Object
Dim Template as String
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
Template = "C:\Users\me\Dropbox\me - Summer 2019\RMA_Log\00059-001_E_24May19_Form Returned Authorization.docx"
Set WordDoc = WordApp.Documents.Open(FileName:=Template, ReadOnly:=False)
With WordDoc.Content.Find
.Text = "<Date>"
.Replacement.Text = "06-06-2019"
.Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
End With
But this won't replace any text in the main body of my word document.
I've tried doing WordDoc.ActiveDocument.Content.Find but that also doesn't work. If I copy the code exactly and replace WordDoc with ActiveDocument and run it in word VBA, the text gets replaced.
Dim Template As String
Template = "C:\Users\me\Dropbox\me - Summer 2019\RMA_Log\00059-001_E_24May19_Form Returned Authorization.docx"
With ActiveDocument.Content.Find
.Text = "<Date>"
.Replacement.Text = "06-06-2019"
.Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue
End With
If I run this code in Word VBA, it replaces the Tag, why wouldn't it work to run this from Excel?
Edit: Office 2016
Excel doesn't know what wdReplaceAll or wdFindContinue are.
Put a reference to the Word Object Model (Tools > References > Microsoft Word XX Object Model).
And if you have Option Explicit at the top of your code it would highlight this.