Sub GetPatentData()
Application.ScreenUpdating = False
Dim Tbl As Table, i As Long, j As Long, k As Long, l As Long, lRow As Long, ArrFnd, ArrFnd1
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, Simi As String, StrTxt1 As String
'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
'Word Find expressions
ArrFnd = Array("[!W][A-Z] [0-9]{7,10} [A-Z0-9]{2}")
ArrFnd1 = Array("WO [0-9]{5,} [A-Z0-9]{1,2}^13*^13[A-VX-Z][A-Z]")
'Excel workbook name & path
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Desktop\Database.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
        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 = Replace(.Text, Chr(32), ""): bFnd = True
              Set xlRng = xlWkSht.Range("A1:A" & lRow).Find(What:=StrTxt, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False)
                If Not xlRng Is Nothing Then
                  l = xlRng.Row
                  With xlWkSht
                    'Get the worksheet data from columns 3 & 2
                    StrTxt = .Cells(l, 2).Text
                    If (StrTxt <> "") And (.Cells(l, 2).Text <> "") Then
                      StrTxt = StrTxt & vbCr
                    End If
                    StrTxt = StrTxt & .Cells(l, 3).Text
                    'Add the worksheet data from columns 3 & 2 to column 5 of the table
                    With Tbl.Cell(i, 5).Range
                      If Len(.Text) > 2 Then
                        .InsertBefore StrTxt & vbCr
                      Else
                        .InsertBefore StrTxt
                      End If
                    End With
                    'Get the worksheet data from columns 4 & 5
                    StrTxt = .Cells(xlRng.Row, 4).Text
                    If (StrTxt <> "") And (.Cells(l, 5).Text <> "") Then
                      StrTxt = StrTxt & vbCr & "Er.Prio: "
                    ElseIf .Cells(l, 5).Text <> "" Then
                      StrTxt = "Er.Prio: "
                    End If
                    StrTxt = StrTxt & .Cells(l, 5).Text
                    'Add the worksheet data from columns 4 & 5 to column 4 of the table
                    With Tbl.Cell(i, 4).Range
                      If Len(.Text) > 2 Then
                        .InsertBefore StrTxt & vbCr
                      Else
                        .InsertBefore StrTxt
                      End If
                    End With
                  End With
                End If
            End If
            If bFnd = True Then Exit For
          Next
        End With
      Next
      .AllowAutoFit = bFit
    End With
  Next
End With
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
        With .Cell(i, 2).Range
          'Find the references
          For k = 0 To UBound(ArrFnd)
            StrFnd = ArrFnd1(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, vbCr)(0)
              StrTxt1 = Split(.Text, vbCr)(2)
              MsgBox (StrTxt)
              MsgBox (StrTxt1)
              StrTxt = Replace(StrTxt, Chr(32), ""): bFnd = True
              Set xlRng = xlWkSht.Range("A1:A" & lRow).Find(What:=StrTxt, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True, SearchFormat:=False)
                If Not xlRng Is Nothing Then
                  l = xlRng.Row
                  With xlWkSht
                    'Get the worksheet data from columns 3 & 2
                    StrTxt = .Cells(l, 2).Text
                    If (StrTxt <> "") And (.Cells(l, 2).Text <> "") Then
                      StrTxt = StrTxt & vbCr & "Claims similar to " & StrTxt1
                    End If
                    'Add the worksheet data from columns 3 & 2 to column 5 of the table
                    With Tbl.Cell(i, 5).Range
                      If Len(.Text) > 2 Then
                        .InsertBefore StrTxt & vbCr & "Claims similar to" & StrTxt1
                      Else
                        .InsertBefore StrTxt
                      End If
                    End With
                    'Get the worksheet data from columns 4 & 5
                    StrTxt = .Cells(xlRng.Row, 4).Text
                    If (StrTxt <> "") And (.Cells(l, 5).Text <> "") Then
                      StrTxt = StrTxt & vbCr & "Er.Prio: "
                    ElseIf .Cells(l, 5).Text <> "" Then
                      StrTxt = "Er.Prio: "
                    End If
                    StrTxt = StrTxt & .Cells(l, 5).Text
                    'Add the worksheet data from columns 4 & 5 to column 4 of the table
                    With Tbl.Cell(i, 4).Range
                      If Len(.Text) > 2 Then
                        .InsertBefore StrTxt & vbCr
                      Else
                        .InsertBefore StrTxt
                      End If
                    End With
                  End With
                End If
            End If
            If bFnd = True Then Exit For
          Next
        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

column 2 cell
WO 2015171641 A1¶
Some text¤