'=============================================================================================
'- WORD MACRO
'- TO USE A LIST IN AN EXCEL WORKSHEET TO FIND WORDS IN THE CURRENTLY ACTIVE DOCUMENT
'- this example highlights those words
'=============================================================================================
'- ** In Word VB Editor ... Tools/References ......
'- ** ..... check the reference to "Microsoft (??) Excel Object Library"
'- Brian Baulsom November 2007
'=============================================================================================
'- Excel
Dim ExcelPath As String ' [*] Amend as required below
Dim MyWorkbookName As String ' [*] Amend as required below
Dim MyLookupSheetName As String ' [*] Amend as required below
'---------------------------------------------------------------------------------------------
Dim xlApp As Object ' Excel Application Object
Dim MyWorkbook As Object
Dim MyLookupSheet As Object
Dim FromRow As Long
Dim LastRow As Long
Dim SearchString As String ' string to find in Word
Dim CountAll As Integer ' count all to find
Dim CountFound As Integer ' count found items
'---------------------------------------------------------------------------------------------
'- Word
Dim WordDoc As Document
Dim WordRange As Range ' text range
'=============================================================================================
'- MAIN ROUTINE
'=============================================================================================
Sub EXCEL_LOOKUP()
'-----------------------------------------------------------------------------------------
'- NB. NEED TO AMEND THESE VARIABLES TO SUIT YOUR SETUP
'-----------------------------------------------------------------------------------------
ExcelPath = ActiveDocument.Path ' this assumes same folder as Word Document
MyWorkbookName = "XL to Word List.xls" '[*] AMEND
MyLookupSheetName = "LookupSheet" '[*] AMEND
'-----------------------------------------------------------------------------------------
'- Word
Set WordDoc = ActiveDocument
Set WordRange = WordDoc.Content
WordRange.HighlightColorIndex = wdNone ' remove any highlighting
CountAll = 0
CountFound = 0
'-----------------------------------------------------------------------------------------
'- OPEN EXCEL APPLICATION
'-----------------------------------------------------------------------------------------
'- See if Excel is open already (next line gives error if not)
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application") ' set variable if Excel already open
'-----------------------------------------------------------------------------------------
'- check for error
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application") ' open Excel application
End If
On Error GoTo 0 ' reset error trapping
'-----------------------------------------------------------------------------------------
'- USE EXCEL
'-----------------------------------------------------------------------------------------
With xlApp
.Visible = True ' show Excel
'-------------------------------------------------------------------------------------
'- Excel workbook & worksheet
MyWorkbookName = ExcelPath & "\" & MyWorkbookName
Set MyWorkbook = .Workbooks.Open(FileName:=MyWorkbookName)
Set MyLookupSheet = MyWorkbook.Worksheets(MyLookupSheetName)
LastRow = MyLookupSheet.Range("A65536").End(xlup).Row
'-------------------------------------------------------------------------------------
'- loop through Excel rows
For FromRow = 3 To LastRow
CountAll = CountAll + 1
SearchString = MyLookupSheet.Cells(FromRow, "A").Value
FindTextInWordDocument
Next
End With
'-----------------------------------------------------------------------------------------
'- FINISH
'-----------------------------------------------------------------------------------------
'- WORD : close document
'WordDoc.Close savechanges:=False
'-----------------------------------------------------------------------------------------
'Close Excel ( & clear variables from memory)
' With xlApp
' .MyWorkbook.Close savechanges:=False ' close workbook
' .Quit ' close Excel Application
' End With
' Set MyWorkbook = Nothing
' Set MyLookupSheet = Nothing
' Set xlApp = Nothing
'------------------------------------------------------------------------------------------
MsgBox ("Done" & vbCr _
& "Looked for " & CountAll & " items." & vbCr & "Found " & CountFound & " matches.")
End Sub
'======== END OF MAIN SUB =====================================================================
'=============================================================================================
'- WORD MACRO : FIND TEXT IN THE DOCUMENT - called fom Main Sub ()
'=============================================================================================
Private Sub FindTextInWordDocument()
'- reset search range
Set WordRange = WordDoc.Content
'-----------------------------------------------------------------------------------------
'- Set up Find parameters & find the text
With WordRange.Find
.ClearFormatting
.Text = SearchString
.Wrap = wdFindStop
.Format = False
.Execute
End With
'-----------------------------------------------------------------------------------------
'- what to do if text is found
While WordRange.Find.Found
CountFound = CountFound + 1
WordRange.HighlightColorIndex = wdYellow
'-------------------------------------------------------------------------------------
'- find next
WordRange.Find.Execute
Wend
End Sub
'---------------------------------------------------------------------------------------------