I'm writing a macro (in excel) that uses .docx template and replaces strings with the values from excel file. Everything works fine except the fact that the format of pasted value is the same as of replaced string (in this case all pasted value is in uppercase), not the value format from excel. How could I change this code so the pasted value will keep its' format from excel?
Sub fromexcel()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets(1)
Dim objWord
Dim objDoc
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("\\xxxxx\Template.docx")
objWord.Visible = True
objDoc.Activate
With objDoc.Range.Find
If ws.Range("B13").Value <> "" Then
objDoc.FormFields(3).CheckBox.Value = True
.Text = "AAAAA"
.ClearFormatting
.Replacement.Text = ws.Range("B13").Value
.Replacement.ClearFormatting
.Replacement.Font.Italic = False
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
Else:
.Text = "AAAAA"
.ClearFormatting
.Replacement.Text = ""
.Replacement.ClearFormatting
.Replacement.Font.Italic = False
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End If
I tried different combinations with or without ".ClearFormatting" and .format = true/false but nothing seems to work.
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
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
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
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 need selection particular content each paragraph in ms word 2013. I try to select content using by vba script..
Sub RepalaceStrong()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "<Strong"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Extend
With Selection.Find
.Text = "</Strong>"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
End Sub
But i tried this code, i can't select one by one text.
Input:
In general, a vector field is a function whose domain is a set of points in <Strong> a vector field is </Strong> a vector field is <Strong>function</Strong> whose domain is a set of points
>In general, a vector field is a function whose <Strong>domain</Strong> is a set of points
Is it possible to select one by one all strong elements...
You need to specify the correct font formatting in your find operation (note the .Font.Bold = True part below):
With Selection.Find
.ClearFormatting
.Font.Bold = True
.Replacement.ClearFormatting
.text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Then, of course, it depends what you want to do with the bold text. Currently the code above just configures the Find object to search for bold text.
It's not strong you're looking for, it's Font.Bold
Option Explicit
Sub FindBold()
Dim myDoc As Document
Set myDoc = ThisDocument
Dim searchRange As Range
Dim foundRange As Range
Set searchRange = myDoc.Range(0, myDoc.Range.End)
With searchRange.Find
.ClearFormatting
.Forward = True
.Font.Bold = True
.Execute
Do While .Found
Set foundRange = searchRange
foundRange.Select
foundRange.Collapse direction:=wdCollapseEnd
MsgBox "Found bold text."
.Execute
Loop
End With
End Sub
My ans:
Sub RepalaceStrong()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "<Strong"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Extend
With Selection.Find
.Text = "</Strong>"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Collapse Direction:=wdCollapseEnd
End Sub
I got it ....