'Extract Data From Text file based on Pattern
Sub GetPatentData()
Application.ScreenUpdating = False
Dim Tbl As Table, i As Long, j As Long, k As Long, lRow As Long, ArrFnd, ArrFnd1, ArrFnd2
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, StrTxt1 As String, StrTxt2 As String, StrTxt3 As String, StrTxt4 As String, StrWkBkNm As String, StrFnd As String, StrWkSht As String, Simi As String
'Word Find expressions
ArrFnd = Array("[!W][A-Z] [0-9]{5,} [A-Z0-9]{1,2}")
ArrFnd1 = Array("WO [0-9]{5,} [A-Z0-9]{1,2}^13*13[A-VX-Z][A-Z]")
ArrFnd2 = Array("WO [0-9]{5,} [A-Z0-9]{1,2}")
'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") & "\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
        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 = Replace(.Text, Chr(32), "")
              With xlWkSht
                Set xlRng = .Range("A1:A" & lRow).Find(What:=StrTxt, _
                  LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True,       SearchFormat:=False)
                If Not xlRng Is Nothing Then
                  StrTxt = .Cells(xlRng.Row, 2).Text
                  StrTxt1 = .Cells(xlRng.Row, 3).Text
                  StrTxt2 = .Cells(xlRng.Row, 4).Text
                  StrTxt3 = .Cells(xlRng.Row, 5).Text
                  StrTxt4 = .Cells(xlRng.Row, 6).Text
                Else
                  StrTxt = ""
                End If
              End With
            End If
            If bFnd = True Then Exit For
          Next
        End With
        With .Cell(i, 5).Range
          If Len(.Text) > 2 Then
            .InsertBefore StrTxt1 & vbCr
          Else
            .InsertBefore StrTxt1
          End If
        End With
        With .Cell(i, 5).Range
          If Len(.Text) > 2 Then
            .InsertBefore StrTxt & vbCr
          Else
            .InsertBefore StrTxt
          End If
        End With
        With .Cell(i, 4).Range
          If Len(.Text) > 2 Then
            .InsertBefore StrTxt2 & vbCr
          Else
            .InsertBefore StrTxt2
          End If
        End With
        With .Cell(i, 4).Range
          If Len(.Text) > 2 Then
            .InsertBefore "Er.Prio: " & StrTxt3 & vbCr
          Else
            .InsertBefore "Er.Prio: " & StrTxt3
          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