Try:
Code:
Sub GetPatentStatus()
Application.ScreenUpdating = False
Dim Tbl As Table, i As Long, j As Long, k As Long, lRow As Long, ArrFnd
Dim xlApp As Object, xlWkBk As Object, xlWkSht As Object, xlRng As Object
Dim bStrt As Boolean, bFnd As Boolean, bOpen As Boolean, bBar As Boolean, bFit As Boolean
Dim StrTxt As String, StrWkBkNm As String, StrFnd As String, StrWkSht As String
'Word Find expressions
ArrFnd = Array("US [0-9]{7}", "US [0-9,]{9}", "US RE[0-9]{5}")
'Excel constants for use with late binding
Const xlCellTypeLastCell As Long = 11: Const xlValues As Long = -4163
Const xlWhole As Long = 1: Const xlByRows As Long = 1
'Excel workbook name & path
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Downloads\Database1.xlsx"
'Excel worksheet name
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
Exit Sub
End If
bStrt = False ' Flag to record if we start Excel, so we can close it later.
bOpen = False ' Flag to record if we open the workbook, so we can close it later.
' Test whether Excel is already running.
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
'Start Excel if it isn't running
If xlApp Is Nothing Then
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
MsgBox "Can't start Excel.", vbExclamation
Exit Sub
End If
' Record that we've started Excel.
bStrt = True
End If
On Error GoTo 0
With xlApp
'Hide our Excel session if we started it
If bStrt = True Then .Visible = False
'Check if the workbook is open.
For Each xlWkBk In .Workbooks
If xlWkBk.FullName = StrWkBkNm Then ' It's open
Set xlWkBk = xlWkBk
bOpen = True
Exit For
End If
Next
' If not open by the current user.
If bOpen = False Then
' Check if another user has it open.
If IsFileLocked(StrWkBkNm) = True Then
' Report and exit if true
MsgBox "The Excel workbook is in use." & vbCr & "Please try again later.", vbExclamation, "File in use"
GoTo ErrExit
End If
' The file is available, so open it.
Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm)
If xlWkBk Is Nothing Then
MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
GoTo ErrExit
End If
End If
On Error Resume Next
Set xlWkSht = xlWkBk.Sheets(StrWkSht)
On Error GoTo 0
If xlWkSht Is Nothing Then
MsgBox "Cannot find the worksheet named: '" & StrWkSht & "' in:" & vbCr & StrWkBkNm, vbExclamation
GoTo ErrExit
End If
With xlWkSht.UsedRange
lRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
End With
End With
' Store current Status Bar status, then switch on
bBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
With ActiveDocument
For Each Tbl In .Tables
With Tbl
bFit = .AllowAutoFit
.AllowAutoFit = False
j = .Rows.Count
For i = 1 To j
Application.StatusBar = "Processing row " & i & " of " & j
StrTxt = ""
With .Cell(i, 2).Range.Paragraphs(1).Range
'Find the references
For k = 0 To UBound(ArrFnd)
StrFnd = ArrFnd(k): bFnd = False
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Format = False
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Text = StrFnd
.Execute
End With
If .Find.Found Then
StrTxt = Split(.Text, " ")(1): bFnd = True
With xlWkSht
Set xlRng = .Range("A1:A" & lRow).Find(What:=StrTxt, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False)
If Not xlRng Is Nothing Then
StrTxt = .Cells(xlRng.Row, 3).Text
Else
StrTxt = ""
End If
End With
End If
If bFnd = True Then Exit For
Next
End With
With .Cell(i, 3).Range
If Len(.Text) > 2 Then
.InsertBefore StrTxt & vbCr
Else
.InsertBefore StrTxt
End If
End With
Next
.AllowAutoFit = bFit
End With
Next
End With
' Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = bBar
MsgBox "Finished!", vbInformation
ErrExit:
If Not xlWkBk Is Nothing Then If bOpen = False Then xlWkBk.Close
If Not xlApp Is Nothing Then If bStrt = True Then xlApp.Quit
Set xlRng = Nothing: Set xlWkSht = Nothing: Set xlWkBk = Nothing: Set xlApp = Nothing
Application.ScreenUpdating = True
End Sub
Function IsFileLocked(strFileName As String) As Boolean
On Error Resume Next
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
IsFileLocked = Err.Number
Err.Clear
End Function
As coded, the macro looks in your Downloads folder for the Database1.xlsx file and Sheet1 in that workbook. You can substitute another folder, Excel file or worksheet if you prefer.