I am trying to create an excel based tool that reviews Word documents for specific errors. I want this tool to search for a word/sentence and insert a comment against it. I have written a code (please see below) that is able to highlight the word/sentence, however, unable to insert the comment.
Here is my code so far:
Sub Ref_Figs_Tbls()
Dim wdDoc As Object
Set wdDoc = ActiveDocument
With wdDoc
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "Reference source not found"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
.Select
.HighlightColorIndex = wdRed
.Select
Selection.Comments.Add Range:=Selection.Range
Selection.TypeText Text:="Cross referencing error"
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
End Sub
Since you say you're acting from within Excel Application, then an unqualified Selection
object would reference the host application, i.e. it'd return the Excel Selection
edited to add a Word host application code
Hence you have to explicitly qualify Word application object as the Parent
of the wanted Selection
object (which I can't see any trace of in your code, though...)
Sub Ref_Figs_Tbls()
Dim WordApp As Object
'try and get Word application object, or exit sub
Set WordApp = GetObject(, "Word.Application")
If WordApp Is Nothing Then Set WordApp = CreateObject("Word.Application")
If WordApp Is Nothing Then: MsgBox "Can't get a Word instance", vbCritical: Exit Sub
With WordApp.ActiveDocument ' reference word application currently active document
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.text = "Reference source not found"
.Replacement.text = ""
.Execute
End With
Do While .Find.Found = True
.Select
With WordApp.Selection ' explicitly reference Word application object selection
.Range.HighlightColorIndex = wdRed
.Range.Comments.Add Range:=.Range '.Find.Parent
.text = "Cross referencing error"
End With
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
End With
Set WordApp = Nothing
End Sub
BTW you don't need all that Select/Selection work, and you can directly work with wanted objects
for instance the Do While .Find.Found = True
loop can turn into
Do While .Find.Found = True
With .Find ' reference the Find object
.Parent.HighlightColorIndex = wdRed ' set Find Parent object (i.e. its Range) color
.Parent.Comments.Add(Range:=.Parent).Range.text = "Cross referencing error" ' set Find Parent object (i.e. its Range) comment object text
.Execute
End With
Loop
using Word as host application, the above code would simplify to:
Option Explicit
Sub Ref_Figs_Tbls()
Dim wdDoc As Document
Set wdDoc = ActiveDocument
With wdDoc
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWildcards = True
.Wrap = wdFindStop
.Text = "Reference source not found"
.Replacement.Text = ""
.Execute
End With
Do While .Find.Found = True
With .Find
.Parent.HighlightColorIndex = wdRed
.Parent.Comments.Add(Range:=.Parent).Range.Text = "Cross referencing error"
.Execute
End With
Loop
End With
End With
End Sub
Collected from the Internet
Please contact [email protected] to delete if infringement.
Comments