I get run-time error 13 (Type Mismatch) on my code when I try to run it.
I'm trying to replace a text in a opened Word document through Excel, inside the header.
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Set WordDoc = WordApp.Documents.Open(myPath & "\Armaturförteckning.docx")
' Ändrar i Armaturförteckningen
Dim rngStory As Range
Dim lngJunk As Long
'Fix the skipped blank Header/Footer problem as provided by Peter Hewett
lngJunk = WordApp.ActiveDocument.Sections(1).Headers(1).Range.StoryType
'Iterate through all story types in the current document
For Each rngStory In WordApp.ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
With WordApp.rngStory.Find
.Text = "ELESTATUS01"
.Replacement.Text = "I'm found"
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
'Get next linked story (if any)
Set rngStory = WordApp.rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
' Stänger dokumentet
WordApp.Documents.Save
WordApp.ActiveDocument.Close
I believe you are trying to do a VBA search and replace. We have a BUNCH of functions that we use, and after many years of refinement, the following is what we use. It's purely the function that performs a search and replace.
Function SimpleSearchAndReplace(SomeDocument As Word.Document, SearchString As String, ReplaceString As String)
With SomeDocument.Content.Find
.Text = SearchString
.Replacement.Text = ReplaceString
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End Function
It seems awkward that you have "WordApp.ActiveDocument." when what you probably need is "WordDoc." in your 'lngJunk' and 'For Each' lines.
Related
First and foremost, I'm a novice at this.
The situation is as follows:
A Word template is being edited by a VBA macro upon generating a document. I need to improve the VBA macro by deleting a set string of text (A) and replacing it with a different string of text (B) upon the condition that another specific string of text (C) can be found in the document.
There's a Boolean function
Function findrange(tekst As String) As Boolean
Set place = Documents(ActiveDocument.Name).Content
If place.Find.Execute(findtext:=tekst) = True Then
findrange = True
Else
findrange = False
End If
End Function
By which I can identify if that string of text (A) is found in the document. So far so good.
What I need is to delete that string of text (A), if it is found in the document, upon the condition that another string of text (C) can be found in the document.
How do I go about it? I've tried
If findrange("C") = True Then
If findrange("A") = True Then place.Text = ""
But If True Then doesn't allow nesting Ifs apparently.
You need to set up two Range variables.
Dim rngA as Word.Range
Dim rngC as Word.Range
Then upon finding the Text(A) using your findRange function you need to store the found range in the rngA variable.
Set rngA = place.Range
Next, run the findRange function again using Text(C), and assuming it is found you can then replace the rngA.text with your Text(B) data.
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim RngA As Range, RngB As Range
With ActiveDocument
Set RngA = .Range: Set RngB = .Range
With RngA.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "String C"
.Execute
If .Found = True Then
With RngB.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "String A"
.Replacement.Text = "String B"
.Format = False
.Forward = True
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End If
End With
End With
Application.ScreenUpdating = True
End Sub
I would like to create a macro in MS Word that when run searches the document for text that appears in the body of the document that matches the mail merge field name. Once identified it would change the text in the document to the actual matching mail merge field name. For example, if there was a mail merge field named "project_date" and in the Word document there was the text "project_date" the macro would turn the text into the actual mail merge field "project_date".
Ideally, the macro would do this for all mail merge fields that exists at once.
Below is as far as I have come with formulating my desired code.
I found this code here ( https://answers.microsoft.com/en-us/msoffice/forum/msoffice_word-mso_other-mso_2007/how-do-i-replace-words-in-a-document-with-a-mail/da323980-7c7d-e011-9b4b-68b599b31bf5 ) but it only will do one specified mail merge field at a time.
Dim oRng As Range
Set oRng = ActiveDocument.Range
With oRng.Find
Do While .Execute(FindText:="(Player 1)")
oRng.Fields.Add oRng, wdFieldMergeField, "Player_1", False
oRng.Collapse wdCollapseEnd
Loop
End With
I recorded this myself, but am not sure how to search and replace text with desired merge field.
With Selection.Find
.Text = "project_name"
.Replacement.Text = "project_name"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
The solution for this combines the code for inserting all merge fields into a document with the basic code you found / recorded. Inserting the merge field is moved into the Function that searches the field names in the document. I've set the function up to return the number of times the field is inserted.
The tricky, or special, part of the Function is setting up the Range after a successful Find to continue the search. The end-point of a merge field is still within the merge field, thus the line oRng.MoveStart wdCharacter, 2 is required after collapsing the Range. If the Range stays within the field, the merge field name inside it will be found again, and again, and again...
Sub InsertAllMergeFieldsAtPlaceholders()
Dim doc As word.Document
Dim rng As word.Range
Dim mm As word.MailMergeDataField
Set doc = ActiveDocument
Set rng = doc.content
If doc.MailMerge.MainDocumentType <> wdNotAMergeDocument Then
For Each mm In doc.MailMerge.DataSource.DataFields
Debug.Print ReplaceTextWithMergeField(mm.NAME, rng) & " merge fields inserted for " & mm.NAME
Set rng = doc.content
Next
End If
End Sub
Function ReplaceTextWithMergeField(sFieldName As String, _
ByRef oRng As word.Range) As Long
Dim iFieldCounter As Long
Dim fldMerge As word.Field
Dim bFound As Boolean
With oRng.Find
.ClearFormatting
.Forward = True
.wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
bFound = .Execute(findText:=sFieldName)
End With
Do While bFound
iFieldCounter = iFieldCounter + 1
Set fldMerge = oRng.Fields.Add(oRng, wdFieldMergeField, sFieldName, False)
Set oRng = fldMerge.result
oRng.Collapse wdCollapseEnd
oRng.MoveStart wdCharacter, 2
oRng.End = oRng.Document.content.End
bFound = oRng.Find.Execute(findText:=sFieldName)
Loop
ReplaceTextWithMergeField = iFieldCounter
End Function
I using Macro to find word from checklist and highlight in Word document. But If word not found from list then. I also want to highlight matching word in checklist so that I know these word found and these word missing.
One more It also search word inside word that also need to modify. i.e.
if in checklist I have word Country but it find Count too, I want if find whole word. But first problem is most important.
Sub CompareWordList1()
Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object
sCheckDoc = "D:\List.docx"
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Bold = True
.Replacement.Font.ColorIndex = wdDarkRed
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = True
.MatchWildcards = False
End With
For Each wrdRef In docRef.Words
If Asc(Right(wrdRef, 1)) > 32 Then
With Selection.Find
.Wrap = wdFindContinue
.Text = wrdRef
.Execute Replace:=wdReplaceAll
End With
End If
Next wrdRef
docRef.Close
docCurrent.Activate
End Sub
The key is that .Execute Replace:=wdReplaceAll returns True if the operation was successful and False if nothing was replaced. So we can use this to determine if the word was found or not.
So we can write a function that highlights one word in a document, so that we can re-use that function for different words and different documents:
Option Explicit
Public Function HighlightOneWordInDocument(DocToHighlight As Document, ByVal WordToHighlight As String) As Boolean
If Len(WordToHighlight) = 0 Then Exit Function 'exit if no WordToHighlight is empty otherwise below if fails
If Asc(Right(WordToHighlight, 1)) > 32 Then
With DocToHighlight.Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Bold = True
.Replacement.Font.ColorIndex = wdDarkRed
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = True
.MatchWildcards = False
.Wrap = wdFindContinue
.Text = WordToHighlight
HighlightOneWordInDocument = .Execute(Replace:=wdReplaceAll)
End With
End If
End Function
Then we can use that function to replace a word in a specific document and it returns if True if the word was replaced:
HighlightOneWordInDocument(docCurrent, wrdRef)
'returns true if wrdRef was replaced in docCurrent
So we just need to remember the words that were found in an array, so that we can use that array to highlight your word list in the end:
Sub CompareWordList1()
Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object
sCheckDoc = "D:\List.docx"
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate
Dim FoundWords() As String
ReDim FoundWords(0)
For Each wrdRef In docRef.Words
If HighlightOneWordInDocument(docCurrent, wrdRef) = True Then
'if something was replaced remember this word in the FoundWords array
ReDim Preserve FoundWords(UBound(FoundWords) + 1)
FoundWords(UBound(FoundWords)) = wrdRef
End If
Next wrdRef
'now we go throug the FoundWords array to highlight the list
Dim FoundWord As Variant
For Each FoundWord In FoundWords
HighlightOneWordInDocument docRef, FoundWord
Next FoundWord
docRef.Close 'to save the highligted ist use docRef.Close SaveChanges:=True
docCurrent.Activate
End Sub
I'm trying to find a regex string, <XE "i#>, in a Word document.
Background: I'm building an index, and automatically picking up paragraphs to add via another macro. There are some entries that start "i. Automobile - means a car", or "ii. Super - means really good". I want to remove the numbering part from the Index entry, so thought a way to do so would be to look for the {XE "i. Automobile ...} part and just remove the i. using RegEx.
When I search manually for my string, it works fine and picks up the matches. However, my macro doesn't work. When stepping through, then I get to While .Execute, the next step just goes to Wend then End With. It does ask if I want to search from the beginning, so the .Find is working somewhat, but why isn't it finding any matches?
Thanks so much for any advice!
Sub Hide_Roman_Numerals_from_Index()
Dim defText As String
Dim regExSearch As String
Dim oRng As Word.Range, rng As Word.Range
If ActiveWindow.ActivePane.View.ShowAll = False Then
ActiveWindow.ActivePane.View.ShowAll = True
End If
Set oRng = ActiveDocument.Range
'Call ClearFindAndReplaceParameters(oRng)
regExSearch = "<XE ""i#>"
oRng.Find.ClearFormatting
With oRng.Find
.Text = regExSearch
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
While .Execute
Set rng = oRng.Paragraphs(1).Range
rng.Select
Wend
End With
If ActiveWindow.ActivePane.View.ShowAll = True Then
ActiveWindow.ActivePane.View.ShowAll = False
End If
'Call ClearFindAndReplaceParameters(oRng)
End Sub
I think this approach will suit you if I got your problem right.
'BruceWayne
Sub Colorgreenfromw()
Application.ScreenUpdating = False
Dim oPar As Paragraph
Dim oRng As Word.Range
For Each oPar In ActiveDocument.Paragraphs
Set oRng = oPar.Range
With oRng
With .Find
.ClearFormatting
.Font.Color = wdColorGreen
.Replacement.ClearFormatting
.Text = "<XE ""i#>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
If .Find.Found Then
Set oRng = oPar.Range
oRng.Font.Color = wdColorGreen
Set oRng = Nothing
End If
End With
Next
End Sub
I've been trying to modify the brilliant example given here with little success. Within the MSWord document, I need to be able to find text like <<TEST>> and recover the string found between << and >> which would return TEST. Ultimately I intend to use this to look up a value against TEST and return a string to be replaced within the Word document. ie. <<TEST>> becomes FRED for example.
Sub Sample()
Dim c As Range
Dim StartWord As String, EndWord As String, TheWord As String
StartWord = "<<": EndWord = ">>"
Set c = ActiveDocument.Content
c.Find.ClearFormatting
c.Find.Replacement.ClearFormatting
With c.Find
.Text = "[\<]{2}*[\>]{2}"
'.Replacement.Text = TheWord
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
c.Find.Execute
While c.Find.Found
Debug.Print c.Text
TheWord = Replace(Replace(c.Text, StartWord, ""), EndWord, "")
Debug.Print TheWord
c.Find.Replacement.Text = TheWord
' Future something here to lookup value based on 'TheWord'
c.Find.Execute Replace:=wdReplaceOne
Wend
End Sub
At the moment, I'm just trying to replace those words like <<TEST>> that are found with the string found within. Although it will find and replace the first instance of the text matching the pattern, it doesn't find others like the example will.
Thanks.
Even if sometimes it is not recommended to use Selection within your code I prefer to use it when running find >> replace actions.
In the following code you will find two solutions- 1st is to replace text with one inside << >> brackets, 2nd is to replace with any text. Do not run both at once, comment one to run the other.
Sub Sample()
Dim c As Range
Dim StartWord As String, EndWord As String, TheWord As String
StartWord = "<<": EndWord = ">>"
ActiveDocument.Range(0, 0).Select
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[\<]{2}(*)[\>]{2}"
.Replacement.Text = "\1"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
'DO NOT RUN BOTH OPTIONS TOGETHER, CHOOSE ONE
'OPTION 1. replace to inside text
'Selection.Find.Execute Replace:=wdReplaceAll
'OPTION 2. replace to any text, here- inside text found with replace function
Do While Selection.Find.Execute
Debug.Print Selection.Text
TheWord = Replace(Replace(Selection.Text, StartWord, ""), EndWord, "")
Debug.Print TheWord
Selection.Text = TheWord
Selection.Collapse WdCollapseDirection.wdCollapseEnd
Loop
End Sub