'=============================================================================
'- WORD MACRO : LOOK UP WORD DATA IN AN EXCEL TABLE
'=============================================================================
'- This macro opens and closes Excel (Hidden) for each batch.
'- The search here is limited to Excel column A. Gets 2 items.
'- Problems to overcome are that Word ranges count end of line characters
'- (character 13) as words, and ranges expand if additions are made.
'-----------------------------------------------------------------------------
'- *** NB. Bear in mind that stopping the macro before it finishes
'- *** will leave a hidden Excel instance in computer memory.
'-----------------------------------------------------------------------------
'- Method : select a set of typed lookup values in a document (separate lines)
'- then run the macro to add the extra data.
'- Might be easier to use an InputBox method.
'-----------------------------------------------------------------------------
'- Brian Baulsom October 2008
'=============================================================================
Option Base 1
Dim MyLookupValue As Variant ' lookup value from Word
'- Excel
Dim ExcelApp As Object
Dim ExcelWorkbook As String
Dim ExcelWorksheet As String
Dim FindRange As String ' Excel range to search
Dim FoundCell As Object
Dim FoundRow As Long
'- return values from Excel
Dim ReturnValue1 As Variant
Dim ReturnValue2 As Variant
'- WORD
Dim MyRange As Range
Dim LookupList() ' Array of words to look up
Dim MyWords As Integer ' number of words in the array (including end of line)
'=============================================================================
'- MAIN ROUTINE TO GET LOOKUP VALUES FROM WORD
'=============================================================================
Sub GET_LOOKUPS()
'-------------------------------------------------------------------------
'- define variables
ExcelWorkbook = "F:\TEST\EXCELDATA2.XLS"
ExcelWorksheet = "Sheet1"
'- FindRange = is set to column A below (change as necessary) ***
'------------------------------------------------------------------------
'- open Excel
Set ExcelApp = CreateObject("Excel.Application")
With ExcelApp
.Visible = False
.workbooks.Open ExcelWorkbook
.Worksheets(ExcelWorksheet).Activate
With .Worksheets(ExcelWorksheet)
FindRange = "A2:A" & CStr(.Range("A65536").End(xlUp).Row) '***
'================================================================
'- GET WORD LOOKUP VALUES
'- Could use InputBox etc. instead here
'================================================================
Set MyRange = Selection.Range
MyWords = MyRange.Words.Count - 1
ReDim LookupList(MyWords)
For w = 1 To MyWords
LookupList(w) = MyRange.Words(w)
Next
Set MyRange = Nothing
'------------------------------------------------------------------
'- MOVE WORD SELECTION POINT TO END OF FIRST LINE
Selection.Collapse direction:=wdCollapseStart
Selection.EndKey Unit:=wdLine
'------------------------------------------------------------------
'- LOOK UP WORDS IN THE ARRAY & ADD TO THE END OF LINES IN WORD
For w = 1 To MyWords
MyLookupValue = LookupList(w)
If Asc(MyLookupValue) > 31 Then ' not EOL character 13
EXCEL_LOOKUP MyLookupValue ' call subroutine
'------------------------------------------------------
'- ADD NEW DATA (WITH TABS SEPARATING THEM)
Selection.TypeText _
Text:=vbTab & ReturnValue1 & vbTab & vbTab & ReturnValue2
'------------------------------------------------------
'- MOVE SELECTION POINT DOWN 1 LINE
Selection.MoveDown Unit:=wdLine, Count:=1
'------------------------------------------------------
End If
Next
'================================================================
End With
'--------------------------------------------------------------------
'- CLOSE EXCEL APP
.ActiveWorkbook.Close savechanges:=False
.Quit
End With
'-------------------------------------------------------------------------
Beep
Set ExcelApp = Nothing
End Sub
'======== end of main routine ===============================================
'============================================================================
'- SUBROUTINE : LOOK UP IN EXCEL & GET REQUIRED DATA
'============================================================================
Private Sub EXCEL_LOOKUP(LookupValue)
With ExcelApp.Worksheets(ExcelWorksheet)
'----------------------------------------------------------------
'- FIND DATA
Set FoundCell = _
.Range(FindRange).Find(What:=LookupValue, _
After:=.Range(FindRange).Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
'----------------------------------------------------------------
If FoundCell Is Nothing Then
ReturnValue1 = "Not found"
ReturnValue2 = "------------"
Else
FoundRow = FoundCell.Row
ReturnValue1 = .Cells(FoundRow, 2).Value
ReturnValue2 = .Cells(FoundRow, 3).Value
End If
'--------------------------------------------------------------------
End With
End Sub
'============================================================================
