Allen Wyatt posted this code on his website, "Paul has a document that he needs to check against a word list contained in another document. If the document being checked contains one of the words in the list, then the word in the document (not in the word list) needs to be highlighted by being made bold."
I want to modify this code to highlight matching words between the active document and checklist file only in the checklist file, but not in the active document, is this possible?
Sub CompareWordList()
Dim sCheckDoc As String
Dim docRef As Document
Dim docCurrent As Document
Dim wrdRef As Object
sCheckDoc = "c:\checklist.doc"
Set docCurrent = Selection.Document
Set docRef = Documents.Open(sCheckDoc)
docCurrent.Activate
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Bold = True
.Replacement.Text = "^&"
.Forward = True
.Format = True
.MatchWholeWord = True
.MatchCase = True
.MatchWildcards = False
End With
For Each wrdRef In docRef.Words
If Asc(Left(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
This should work:
Dim docList As Document, docText As Document, wd As Variant
Set docList = Documents("Document2") 'list of words
Set docText = Documents("Document1") 'some body of text
For Each wd In docList.Words
With docText.Content.Find
.Forward = True
.MatchWholeWord = True
.MatchCase = False
.Text = Trim(wd.Text)
wd.Font.Bold = .Execute
End With
Next wd
Related
this is my first post here!
I am new to Microsoft VBA, but I need to write some macros to quickly make the same changes to 200+ documents. I took the Udemy course on Word VBA but I am stuck trying to figure out how to address the following issues:
I need to select all content from beginning of doc up until the first occurrence of the string "following:" including the string itself - the issue is that for each doc, this string will always be in a different position and the portion I want to delete will vary in length. The only guarantee is that it will always be on the first page.
I need to do the same thing for the end of the document - I need to delete all content following the string "Affirmative Defenses" including the string itself - again, this will always be in a different position and will not always be on the last page (unlike issue number 1)
I have written many variations by reading other questions/solutions with no luck. Below is my current version but it does not work.
Sub DeleteBegin()
Dim findRng As Range
Set findRng = ActiveDocument.Range
Dim endPara As Long
With findRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "following."
.Replacement.Text = ""
.Wrap = wdFindStop
.MatchWholeWord = True
.Forward = True
.Execute
If .Found = True Then
endPara = GetParaNum(findRng)
findRng.Start = 0
findRng.End = endPara
End If
Dim capRng As Range
Set capRng = ActiveDocument.Range
capRng.SetRange Start:=0, End:=endPara
capRng.Select
Selection.Delete
End With
End Sub
Function GetParaNum(ByRef r As Object) As Integer
Dim rPara As Object
Dim CurPos As Long
r.Select
CurPos = ActiveDocument.Bookmarks("\startOfSel").Start
Set rPara = ActiveDocument.Range(Start:=0, End:=CurPos)
GetParaNum = rPara.Paragraphs.Count
End Function
Try:
Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range
With ActiveDocument
Set Rng = .Range(0, 0)
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "following."
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.Execute
End With
If .Find.Found = True Then
Rng.End = .Duplicate.End
Rng.Delete
End If
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Affirmative Defenses"
.Replacement.Text = ""
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchCase = True
.Execute
End With
If .Find.Found = True Then
Set Rng = .Duplicate
Rng.End = ActiveDocument.Range.End
Rng.Delete
End If
End With
End With
Application.ScreenUpdating = True
End Sub
I am not familiar with VBA at all.
I want to search for text I select (rather than a given list of words or typing that text in a box), and then change its format (preferably make it bold or change its color).
I tried to change a few macros that I found.
The VBA code for this can be rather simple. For example:
Sub MakeBold()
Application.ScreenUpdating = False
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Replacement.Font.Bold = True
.Text = Selection.Text
.Replacement.Text = "^&"
.Forward = True
.Wrap = wdFindContinue
.Format = True
.Execute Replace:=wdReplaceAll
End With
End With
Application.ScreenUpdating = True
End Sub
For PC macro installation & usage instructions, see: http://www.gmayor.com/installing_macro.htm
For Mac macro installation & usage instructions, see: https://wordmvp.com/Mac/InstallMacro.html
This will do what you want. Copy/paste into your VB editor window.
Sub HighlightWords()
Dim Word As Range
Dim WordCollection(2) As String
Dim Words As Variant
'Define list.
'If you add or delete, change value above in Dim statement.
WordCollection(0) = "you"
WordCollection(1) = "or"
WordCollection(2) = "Word document"
'Set highlight color.
Options.DefaultHighlightColorIndex = wdYellow
'Clear existing formatting and settings in Find feature.
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'Set highlight to replace setting.
Selection.Find.Replacement.Highlight = True
'Cycle through document and find words in collection.
'Highlight words when found.
For Each Word In ActiveDocument.Words
For Each Words In WordCollection
With Selection.Find
.Text = Words
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Next
Next
End Sub
Before:
After:
I want to delete a paragraph that starts with string "Page:" from the selection
Here is the sample text that I have:
Page: 28
Page: 44 contains a lot of example. But look up here for the detailed
explanation. This may go for more than one, two or three lines. This
totally depends upon the length of the text
Date: 10 Jan 2018
Some text goes here with Page: 108
I’ve some more text here
Few more
Final Text
Page: 208
This is the end
The code I have so far:
Sub DelPara()
Dim para As Paragraph
With Selection.Range.Find
.ClearFormatting
.Text = "[^13^11]Page:"
.Forward = True
.MatchWildcards = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
If (Selection.Range.Find = True) Then
para.Range.Delete
End If
End With
End Sub
The output should be
Date: 10 Jan 2018
Some text goes here with Page: 108
I’ve some more text here
Few more
Final Text
This is the end
The code below will search all instances of the search term in the current selection and delete the search term plus the entire paragraph in which the end of the term is located.
The key to this is using two Range objects: one for the original Range to be searched (the selection), the other for the actual search. In this way, the range that performs the actual search can be extended from the end of the last successful search to the end of the original range.
Sub DelPara()
Dim rngFind As Word.Range, rngSel As Word.Range
Dim para As Paragraph
Dim bFound As Boolean
Set rngSel = Selection.Range
Set rngFind = rngSel.Duplicate
With rngFind.Find
.ClearFormatting
.text = "[^13^11]Page:"
.Forward = True
.MatchWildcards = True
.wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
bFound = rngFind.Find.Execute
Do While bFound
rngFind.End = rngFind.paragraphs.Last.Range.End
rngFind.Delete
rngFind.Collapse wdCollapseEnd
rngFind.End = rngSel.End
bFound = rngFind.Find.Execute
Loop
End Sub
All you need is a wildcard Find/Replace with:
Find = ^13Page:[!^13]{1,}
Replace = nothing
No code required. At most, you might need to insert an empty paragraph at the beginning of the document and delete it afterwards - but then only if the first para starts with 'Page:'. Nevertheless, as a macro:
Sub Demo()
Application.ScreenUpdating = False
With ActiveDocument.Range
.InsertBefore vbCr
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^13Page:[!^13]{1,}"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
.Characters.First = vbNullString
End With
Application.ScreenUpdating = True
End Sub
If you want to process only the selected range, change 'ActiveDocument' to 'Selection'.
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 new to VBA. I have several long documents where a citation or a document number appears at the end of a paragraph. Luckily, these citations and document are enclosed in parentheses, which should make it easy to isolate. I need to move the content of those parentheses (including the parentheses themselves) to the front of each paragraph and then add two spaces after the closing parenthesis.
For example:
This is my text in Paragraph 1. (http://nytimes.com)
This is my text in Paragraph 2. (1.b.3B)
Should look like:
(http://nytimes.com) This is my text in Paragraph 1.
(1.b.3B) This is my text in Paragraph 2.
I found the answer in the following link useful, but can't seem to apply it to my case: Get paragraph no where txt is found, and move text to end of paragraph using Word 2010 vba
Many thanks in advance.
Here's what I have up to now, but the script just doesn't seem to run:
Sub Test1()
Dim currDoc As Document
Set currDoc = ActiveDocument
Dim docRng As Range, currRng As Range, strRng As Range
Set docRng = ActiveDocument.Content
Dim currPara As Paragraph
Dim strText As String
Selection.HomeKey Unit:=wdStory ' Start from the beginning of the doc.
For Each currPara In docRng.Paragraphs ' Loop through the paragraphs in the active document.
Set currRng = currDoc.Range(currPara.Range.Start, currPara.Range.End) ' Selects the current paragraph, so that the search is conducted paragraph by paragraph.
With Selection.Find
.ClearFormatting
.Text = "\(*\)"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
If currRng.Find.Execute Then
With Selection
.Select
.Cut
.StartOf Unit:=wdParagraph
.Paste
.InsertAfter " "
End With
End If
Next currPara
End Sub
You were very close to correct solution to move simple text. But, what I realised, it was a problem to move hyperlinks as syntax "\(*\)" didn't recognise hyperlinks. Therefore I put some additional small modifications. That works for me in Word 2010:
Sub Test1_Tested_incl_Hyper()
Dim currDoc As Document
Set currDoc = ActiveDocument
Dim docRng As Range, currRng As Range, strRng As Range
Set docRng = ActiveDocument.Content
Dim currPara As Paragraph
Dim strText As String
Selection.HomeKey Unit:=wdStory ' Start from the beginning of the doc.
For Each currPara In docRng.Paragraphs ' Loop through the paragraphs in the active document.
Set currRng = currDoc.Range(currPara.Range.Start, currPara.Range.End) ' Selects the current paragraph, so that the search is conducted paragraph by paragraph.
currRng.Select
With Selection.Find
.ClearFormatting
.Text = "\("
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute
End With
If Selection.Find.Found Then
With currDoc.Range(Selection.Range.Start, currPara.Range.End - 1)
.Select
.Cut
.StartOf Unit:=wdParagraph
.Paste
.InsertAfter " "
End With
End If
Next currPara
End Sub
EDIT- code for footers
Sub Test1_for_Footers()
Dim currDoc As Document
Set currDoc = ActiveDocument
Dim docRng As Range, currRng As Range, strRng As Range
Set docRng = ActiveDocument.StoryRanges(wdPrimaryFooterStory)
Dim currPara As Paragraph
Dim strText As String
For Each currPara In docRng.Paragraphs
currPara.Range.Select
With Selection.Find
.ClearFormatting
.Text = "\("
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = True
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Execute
End With
If Selection.Find.Found Then
Selection.Extend ")"
With Selection
.Select
.Cut
.StartOf Unit:=wdParagraph
.Paste
.InsertAfter " "
End With
End If
Next currPara
End Sub