My goal is to create a spread sheet that will feed information into a form letter, create a new folder, then save the letter to the new folder and repeat.
The code below completes one iteration, but runs into an error on the second loop
remote procedure call failed
I think it is an issue with re-opening the template on the second run.
Public Sub WordFindAndReplace()
Dim ws As Worksheet, msWord As Object, itm As Range, fileName As String, Path As String
Set ws = ActiveSheet
Set msWord = CreateObject("Word.Application")
Set objdoc = msWord.Documents.Add
For i = 1 To 4
fileName = Cells(i, 4).Value
Path = "C:\Users\jarafat\Desktop\Variation1\" & fileName & "\" & fileName & ".docx"
If Len(Dir("C:\Users\jarafat\Desktop\Variation1\" & fileName, vbDirectory)) = 0 Then
MkDir "C:\Users\jarafat\Desktop\Variation1\" & fileName
End If
With msWord
.Visible = True
.Documents.Open "C:\Users\jarafat\Desktop\Variation1\VariationTemplate1.docx"
.Activate
With .Activedocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#address"
.Replacement.Text = ws.Cells(i, 1).Value
.Forward = True
.Wrap = 1 'wdFindContinue (WdFindWrap Enumeration)
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2 'wdReplaceAll (WdReplace Enumeration)
End With
With .Activedocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#address1"
.Replacement.Text = ws.Cells(i, 2).Value
.Forward = True
.Wrap = 1 'wdFindContinue (WdFindWrap Enumeration)
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2 'wdReplaceAll (WdReplace Enumeration)
End With
With .Activedocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#Description"
.Replacement.Text = ws.Cells(i, 3).Value
.Forward = True
.Wrap = 1 'wdFindContinue (WdFindWrap Enumeration)
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2 'wdReplaceAll (WdReplace Enumeration)
End With
With msWord.Activedocument
.SaveAs Path
End With
.Quit SaveChanges:=True
End With
Next i
End Sub
The problem comes because the Word application is exited within the loop. So it's no longer available for the second (and following) loops:
.Quit SaveChanges:=True
End With
Next i
You need to do it like this, and it's a good idea to get into the habit of correctly releasing objects (set to Nothing) to outside applications, as well.
End With
Next i
msWord.Quit SaveChanges:=True
Set msWord = Nothing
I also recommend you declare and use a Document object rather than relying on ActiveDocument. There's always the chance that the active document isn't the one you expect. For example:
'At the beginning of the code
Dim doc as Object
'More code...
Set doc = .Documents.Open "C:\Users\jarafat\Desktop\Variation1\VariationTemplate1.docx"
'No need to activate, now...
'Activate
With doc.Content.Find
'And so on until...
.SaveAs Path
'You're done with the document, so release the object
Set doc = Nothing
End With
In addition to Cindy's solution...
Instead of repeating this multiple times with slight variations:
With .Activedocument.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "#address"
.Replacement.Text = ws.Cells(i, 1).Value
.Forward = True
.Wrap = 1 'wdFindContinue (WdFindWrap Enumeration)
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2 'wdReplaceAll (WdReplace Enumeration)
End With
you can make a separate sub:
Sub ReplaceText(doc As Object, findWhat, replaceWith)
With doc.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = findWhat
.Replacement.Text = replaceWith
.Forward = True
.Wrap = 1 'wdFindContinue (WdFindWrap Enumeration)
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=2 'wdReplaceAll (WdReplace Enumeration)
End With
End sub
...and call it from within your loop
Dim doc
With msWord
.Visible = True
Set doc = .Documents.Open("C:\Users\jarafat\Desktop\Variation1\VariationTemplate1.docx")
ReplaceText doc, "#address", ws.Cells(i, 1).Value
ReplaceText doc, "#address1", ws.Cells(i, 2).Value
ReplaceText doc, "#Description", ws.Cells(i, 3).Value
'etc
Related
I have a Word macro that does hundreds of find and replace operations, but currently it applies the operations to the entire document. I need it to only apply to text between "Abstract" (bold, match case) and "References" (bold, match case).
The current code applies changes to the whole document, and then at the end of the macro, it retrospectively rejects any changes to the References with the following code:
With Selection.Find
.ClearFormatting
.Font.Bold = True
.MatchCase = True
.Forward = True
.Execute FindText:="References"
If .Found = True Then
Selection.Find.Execute
Selection.Collapse wdCollapseStart
Dim r1 As Range
Set r1 = Selection.Range
Selection.Find.Text = "DummyText"
Selection.WholeStory
Selection.Collapse wdCollapseEnd
Dim r2 As Range
Set r2 = ActiveDocument.Range(r1.start, Selection.start)
r2.Select
If Selection.Range.Revisions.Count >= 1 Then _
Selection.Range.Revisions.RejectAll
End If
End With
This selects the text between "References" in bold and "DummyText", which is just some text that's guaranteed not to be found so it selects to the end of the document, and then rejects any changes within that selection.
I've tried adapting this and putting it at the start of the macro so that all the find and replace operations only apply to the selection between the Abstract and the References like this:
Selection.Find.ClearFormatting
With Selection.Find
.Text = "Abstract"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.Font.Bold = True
.MatchCase = True
.MatchWholeWord = True
End With
Selection.Find.Execute
Selection.Collapse wdCollapseStart
Dim r1 As Range
Set r1 = Selection.Range
Selection.Find.Text = "References"
Dim r2 As Range
Set r2 = ActiveDocument.Range(r1.start, Selection.start)
r2.Select
' Move cursor to start, turn on tracked changes
Selection.HomeKey Unit:=wdStory
ActiveDocument.TrackRevisions = True
With ActiveWindow.View.RevisionsFilter
.markup = wdRevisionsMarkupSimple
.View = wdRevisionsViewFinal
End With
' start replacements (these go on for ages, two examples here)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Also "
.Replacement.Text = "Additionally, "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "Therefore "
.Replacement.Text = "Therefore, "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
' and so on...
Other threads I've read seem to suggest
.Wrap = wdFindStop
in the replace fields would do what I want, but that doesn't work.
Can anybody help? Cheers.
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Abstract"
.Font.Bold = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
End With
Do While .Find.Execute
Set Rng = .Duplicate
With .Duplicate
.End = ActiveDocument.Range.End
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "References"
.Font.Bold = True
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
If .Find.Found = True Then
Rng.End = .Duplicate.End
Rng.Revisions.RejectAll
End If
End With
Loop
End With
Application.ScreenUpdating = True
End Sub
The above code accommodates multiple 'Abstract' and 'References' blocks, if needed.
You need to use multiple ranges. Once you have established the range to search then if you find something, the first thing you must do is make sure what you found is within the range. The example code below does that.
Sub FindInRange()
Dim rng As Word.Range, rStart As Long, rEnd As Long
Dim iRng As Word.Range
Set rng = ActiveDocument.Content
With rng.Find
.ClearFormatting
.Format = True
.Forward = True
.Font.Bold = True
.MatchCase = True
.MatchWholeWord = True
.Text = "Abstract"
.Wrap = wdFindStop
.Execute
If .found = True Then
rStart = rng.End
rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
.Text = "References"
.Execute
If .found Then
rEnd = rng.Start
End If
End If
End With
If rStart > 0 And rEnd > 0 Then
Set iRng = rng
iRng.Start = rStart
iRng.End = rEnd
Else
Exit Sub
End If
Set rng = iRng
With rng.Find
.ClearFormatting
.Format = True
.Forward = True
.Font.Bold = True
.MatchCase = True
.MatchWholeWord = True
.Text = "Something"
.Wrap = wdFindStop
.Execute
If .found = True And rng.InRange(iRng) Then
'do something
End If
End With
End Sub
I am using the following code to bold parts of a text string, in this case where the word 'Fish' is in brackets after the word 'Oil':
Sub ReplaceAndFormat16()
Dim sConst1 As String, sReplaceMent As String
Dim rRange As Range, rFormat As Range
sConst1 = "Fish"
sReplaceMent = "Oil (" & sConst1 & ")"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "Oil (Fish)"
.Replacement.Text = sReplaceMent
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceOne
If .Found Then
Set rRange = Selection.Range
Set rFormat = ActiveDocument.Range(rRange.Start + 5, rRange.Start + 5 + VBA.Len(sConst1))
rFormat.Font.Bold = True
End If
End With
End Sub
This code works perfectly, but only bolds the first instance, and my documents may have up to four instances of this phrase that need to be formatted bold.
How do I amend the code so it carries on and bolds all instances in the document? I am very new to VBA, so apologies if this seems like a stupid question.
Change the line
.Execute Replace:=wdReplaceOne
to
.execute Replace:=wdReplaceAll
Edit
OK the above was a stupid response. The code below does the right thing
Sub ReplaceAndFormat16()
Const myFindStr As String = "Oil (Fish)"
Dim myFindRange As Word.Range
Set myFindRange = ActiveDocument.StoryRanges(wdMainTextStory)
Do
With myFindRange.Find
.ClearFormatting
.Text = myFindStr
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If .Found Then
With myFindRange
.MoveStartUntil cset:="fF"
.MoveEndUntil cset:="hH", Count:=wdBackward
.Font.Bold = True
.Collapse Direction:=wdCollapseEnd
End With
Else
Exit Sub
End If
End With
Loop
End Sub
How can I delete the text between <de> and the end-of-cell marker throughout my Word document?
I have reached the following code from my previous question. It appeared not to be working because my lines end with end-of-cell markers. So now I need to update this to delete the text between <de>and the end-of-cell marker.
I am unable to implement that in this code.
Sub FindTheDeleteToEndOfLine()
Dim searchTerm As String
Dim bFound As Boolean
searchTerm = "<de>"
Selection.HomeKey wdStory
'Basic Find settings
With Selection.Find
.Forward = True
.wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Execute the Find
Do
With Selection.Find
.Text = searchTerm
bFound = .Execute
If bFound Then
Selection.MoveEnd wdLine, 1
Selection.MoveEnd wdCharacter, -1
Selection.Delete
End If
End With
Loop While bFound
End Sub
Update: I worked out a new code less complicated, but again i am unale to define the arng.words in order to delete last part after <de>:
Dim arng As Range
Dim i As Long, j As Long
With Selection.Tables(1)
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
Set arng = .Cell(i, j).Range
arng.End = arng.End - 1
'Text = "<de>"
If Right(arng.Words, 1) = "<de>" Then
arng.Words.Last = Left(arng.Words, Len(arng.Words) - 1)
End If
Next j
Next i
End With
Try, for example:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "<de>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
If .Information(wdWithInTable) = True Then
.End = .Cells(1).Range.End - 1
.Delete
End If
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Application.ScreenUpdating = True
End Sub
The problem you're encountering here is due to how Word reacts to a selection inside a cell: as soon as it reaches the end of the cell it selects the entire cell.
I've modified the code (which makes it more "complicated") to take this into account. In order to deal with this, there is now a Range object in the code that stores the original "Found" point in the document. After extending the selection to the end of the line, and moving it back one character (which means the entire cell is selected), the starting point is re-set to the "found" position.
Sub FindTheDeleteToEndOfCell()
Dim searchTerm As String
Dim bFound As Boolean
Dim rngFound As Word.Range
searchTerm = "<de>"
Selection.HomeKey wdStory
'Basic Find settings
With Selection.Find
.Forward = True
.wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'Execute the Find
Do
With Selection.Find
.Text = searchTerm
bFound = .Execute
If bFound Then
Set rngFound = Selection.Range
Selection.MoveEnd wdLine, 1
Selection.MoveEnd wdCharacter, -1
Selection.Start = rngFound.Start
Selection.Delete
End If
End With
Loop While bFound
End Sub
I'm trying to find all occurences of certain words in a Word document and erase it but for a reason I don't know, it doesn't erase the words that are in textboxes.
(Note: these are Drawing object textboxes, inserted from a Building Block.)
Here is my code:
Dim myRange As Range
For i = LBound(arr) To UBound(arr)
Set myRange = Selection.Range
myRange.WholeStory
myRange.Select
With objWord.Selection.Find
.ClearFormatting
.Text = arr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
Next i
I tried to add a bit of code to search through the shapes of the word document because I saw it online but it didn't work either.
It looked like this:
Dim myRange As Range
Dim shp As Shape
For i = LBound(arr) To UBound(arr)
Set myRange = Selection.Range
myRange.WholeStory
myRange.Select
With objWord.Selection.Find
.ClearFormatting
.Text = arr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Then
shp.Select
With Selection.Find
.ClearFormatting
.Text = arr(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End If
Next
Next i
These kinds of text boxes are Drawing objects, so your attempt using the Shapes collection was a good start. In order to get to the text range inside a Shape (drawing object) you need the Shape.TextFrame.TextRange property.
I've "tweaked" the code you posted to work from outside of Word:
I fully qualified the Word objects; in order to use the code as it stands it requires a reference to the Word object library in the VBA project.
I've qualified the Word ActiveDocument object with the Word application variable objWord
I've substituted your Range object (myRange) for Selection.Find and set that to the entire body of the Word document
I changed the Find.Wrap setting to wdFindStop because wdFindContinue is very dangerous in VBA (it can go into an infinite loop)
This should get you going.
Sub FindInTextBoxes()
Dim myRange As Word.Range
Dim shp As Word.Shape
Dim shpRange As Word.Range
Dim objWord as Word.Application
Set objWord = GetObject(, "Word.Application")
'Assumes the document is already open in Word
For i = LBound(arr) To UBound(arr)
Set myRange = objWord.ActiveDocument.Content
With myRange.Find
.ClearFormatting
.Text = arr(i)
.Replacement.Text = ""
.Forward = True
.wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
For Each shp In obWord.ActiveDocument.Shapes
If shp.Type = Office.MsoShapeType.msoTextBox Then
Set shpRange = shp.TextFrame.TextRange
With shpRange.Find
.ClearFormatting
.Text = arr(i)
.Replacement.Text = ""
.Forward = True
.wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End If
Next
Next i
End Sub
I set a user Find+Replace All macro, to find and replace all instances of a particular text, and it worked as planned.
However when I recorded that operation as a macro, and ran it, it replaced just the first instance of the find text. What am I doing wrong?
The code that was recorded is a further below.
Sub Macro25()
'
' Macro25 Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Style = ActiveDocument.Styles("Body Text")
With Selection.Find.ParagraphFormat
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorBlack
.BackgroundPatternColor = wdColorBlack
End With
.Borders.Shadow = False
End With
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Style = ActiveDocument.Styles("Body Text 2")
With Selection.Find.Replacement.ParagraphFormat
With .Shading
.Texture = wdTextureNone
.ForegroundPatternColor = wdColorBlack
.BackgroundPatternColor = wdColorBlack
End With
.Borders.Shadow = False
End With
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
The macro is only replacing the text that you have selected when you run the macro. That's what the word Selection means.
If you want the Find/Replace to happen for your whole document, you need to replace Selection in your macro with ActiveDocument.
Thanks for the answer.
So moving on here ... below is the code I wrote myself. It is based on the code produced by the Macro recorder.
My code does not use the same idea of Selection. It uses a rng Range object.
However I get the same effect: that it is finding only the first instance of something.
Function ExecReplaceStyle(strSourceStyle As String, strDestinationStyle As String) As Integer
On Error GoTo ErrorHandler
Dim rng As Range
Dim ret As Integer
ExecReplaceStyle = 0
Set rng = docActiveDoc.Range
With rng.Find
.ClearFormatting
.Style = ActiveDocument.Styles(strSourceStyle)
.Replacement.Style = ActiveDocument.Styles(strDestinationStyle)
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Forward = True
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
rng.Select
rng.Find.Execute Replace:=wdReplaceAll
ExecReplaceStyle = ret
Exit Function
ErrorHandler:
ExecReplaceStyle = Err.Number
ErrDescription = Err.Description
Resume Next
End Function
The Selection.Find.Execute Replace:=wdReplaceAll after the End With should search and replace across the whole document.