Extracting data from excel document using word

PRA007 · #1 11-23-2015, 05:32 AM

I want to extract certain data from excel using word VBA.

I initially posted similar question involving word file https://www.msofficeforums.com/word-...html#post91732. My database manager have changed the database file formate to excel. Apology for asking it again. At that time I could not provide real files and answer was based on what I explained.

Please find files from here.
https://sites.google.com/site/rtsk2015/fo
1. Main.docx
2. Database.xlsx
3. Final.docx

My conditions are frustrating.

Global conditions.

I want to search patent numbers from main.docx column 2 and search correspondingly in database file for that number and extract data from that row to the main.docx.

I always want to search in column 2 cells the first paragraph as it contains multiple numbers sometimes in column 2 cell.
numbering in main.docx and database file are little different

Quote:

main.docx = database.xslx
US 2015328323 A1 = US2015328323A1

Means no space in string

If while importing data form database file, if value is "None", I would like to skip to next step without disturbing anything.
I can modify my database file to replace "None" with "nothing" means empty cell if that is desirable.

Specific Conditions.

1. If column 2 first paragraph contains WO number like WO 2015171641 A1, and if there is paragraph 3 in the same cell containing some number like US 2015322155 A1
for example

Quote:

column 2 cell
WO 2015171641 A1¶
Some text¶
US 2015322155 A1¤

I want to search WO number and add in main.docx following data from database.xlsx.

column 3 = add text "International Publication"
column 4 = Column E from Database.
column 5 = Column B from Database followed by para and add text "claims similar to US."

US comes from whatever present in para 3 first two letter. if it is EP 2943193 A2 I want to add EP or any other country code according to what present in para 3 first two letter.

2. If column 2 first paragraph contains WO number like WO 2015171641 A1, and if there is no paragraph 3.
for example

Quote:

column 2 cell
WO 2015171641 A1¶
Some text¤

I want to search WO number and add in main.docx following data from database.xlsx.

column 3 = add text "International Publication"
column 4 = Column E from Database.
column 5 = column B from database &vbCr & column C from database

3. In every other case irrespective of column 3 present of not for example

Quote:

column 2 cell
US 2015328323 A1¶
Some text¤

or

Quote:

column 2 cell
WO 2015171641 A1¶
Some text¶
US 2015328185 A1¶
US 2015328185 A1¶
US 2015328185 A1¶
US 2015328185 A1¤

I want to search number from first paragraph and search accordingly in database file and import as follow.

column 3
If it already contains some text then= vbCr & add text "Er. Prio.:" & column I from database&
if empty then = add text "Er. Prio.:" & column I.&
column 4 = Column D from Database.
column 5 = column B from database & vbCr & column C from database

Totally understood if conditions are lengthy and unanswerable.

PRA007 · #2 11-25-2015, 12:47 AM

I Think Its very lengthy and tedious to answer this question as a whole.

PRA007 · #3 11-25-2015, 04:54 AM

I found bit of solution using previous reply https://www.msofficeforums.com/word-...d-pattern.html

Code:

'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

Everything works fine without conditions.
I want to improve this macro.
In this macro I tried removing unnecessary conditions but it fails as I don't have sufficient knowledge of VBA.

could anyone please suggest how I can Improve the macro.

Problems
1. I want to skip If .Find.Found Then fails.

Means it adds data every where irrespective of found or not.

2. I could not figure out how to search from paragraph 1 to 5 as current code searches only in paragraph 1. I want to start search string from paragraph 1.

Rest I will update as I learn.
This is my first attempt to try editing macro.

macropod · #4 11-25-2015, 04:19 PM

Quote:

Originally Posted by PRA007

Problems
1. I want to skip If .Find.Found Then fails.

Means it adds data every where irrespective of found or not.

If nothing is found, there is nothing to process and, hence, nothing to add.

Quote:

Originally Posted by PRA007

2. I could not figure out how to search from paragraph 1 to 5 as current code searches only in paragraph 1. I want to start search string from paragraph 1.

What if there is less than 5 paragraphs or more than 5 paragraphs?

PRA007 · #5 11-25-2015, 08:55 PM

Quote:

Originally Posted by macropod

If nothing is found, there is nothing to process and, hence, nothing to add.

As I told, I don't have much knowledge right not regarding vba. I don't know from the code where to skip adding data.

For example

Code:

With .Cell(i, 4).Range
          If Len(.Text) > 2 Then
            .InsertBefore "Er.Prio: " & StrTxt3 & vbCr
          Else
            .InsertBefore "Er.Prio: " & StrTxt3
          End If

from above code it is adding Er.Prio: everywhere irrespective of column 2 search find.

Quote:

Originally Posted by macropod

What if there is less than 5 paragraphs or more than 5 paragraphs?

As I told, I don't have much knowledge right not regarding vba. I Just want to start My search from .Cell(i, 2).Range.Paragraphs(1) but not limited to paragraph(1). There are more/less than one paragraph sometimes in the document.

I don't know how to make this things happen.
My search string is

Code:

WO [0-9]{5,} [A-Z0-9]{1,2}^13*13[A-VX-Z][A-Z]

Please note that this string has nothing to do with current code but have much usefulness on overall process. please see

Quote:

2. If column 2 first paragraph contains WO number like WO 2015171641 A1, and if there is no paragraph 3.
for example

column 2 cell
WO 2015171641 A1¶
Some text¤

I want to search WO number and add in main.docx following data from database.xlsx.

column 3 = add text "International Publication"
column 4 = Column E from Database.
column 5 = column B from database &vbCr & column C from database

PRA007 · #6 11-26-2015, 02:43 AM

The Problem Looks like

Code:

If .Find.Found Then

and

Code:

With .Cell(i, 5).Range

are not linked. I may be wrong.

macropod · #7 11-26-2015, 05:12 AM

Your descriptions are somewhat ambiguous. For example, I still have no idea what you mean about "search from paragraph 1 to 5". It also seems you want more than strings like "WO 2015171641 A1", "US 2015322155 A1" and "EP 2943193 A2", but your "WO [0-9]{5,} [A-Z0-9]{1,2}^13*13[A-VX-Z][A-Z]" Find expression is confused at best (and that's not even a VBA matter). I have to wonder whether you even understand what it would do in this context.

Code-wise, what I have so far, is:

Code:

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
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
'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("[A-Z]{2} [0-9]{7,10} [A-Z0-9]{2}")
'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, 3).Text
                    If (StrTxt <> "") And (.Cells(l, 2).Text <> "") Then
                      StrTxt = StrTxt & vbCr
                    End If
                    StrTxt = StrTxt & .Cells(l, 2).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 StrTxt1 & vbCr
                      Else
                        .InsertBefore StrTxt1
                      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 With
            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

PRA007 · #8 11-26-2015, 08:45 PM

Thanks for spending hours for this.
Code just worked fine.

Quote:

Originally Posted by macropod

Your descriptions are somewhat ambiguous. For example, I still have no idea what you mean about "search from paragraph 1 to 5". It also seems you want more than strings like "WO 2015171641 A1", "US 2015322155 A1" and "EP 2943193 A2", but your "WO [0-9]{5,} [A-Z0-9]{1,2}^13*13[A-VX-Z][A-Z]" Find expression is confused at best (and that's not even a VBA matter). I have to wonder whether you even understand what it would do in this context.

If you read the original post, I have explained how I want my macro to work.
Your code is sufficient to finish the project. I Will post final result to explain what I wanted.

PRA007 · #9 11-26-2015, 10:33 PM

Almost solution:

Code:

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

Left only one stone unturned.

In case of

Code:

column 2 cell
WO 2015171641 A1¶
Some text¤

In this case if there is no third paragraph, I want to run code similar to what you have provided means similar to all other cases.

PRA007 · #10 11-27-2015, 12:53 AM

Is there any Wild card character or something to find end of cell mark?

macropod · #11 11-27-2015, 04:28 AM

Quote:

Originally Posted by PRA007

If you read the original post, I have explained how I want my macro to work.

I did read your original post and it is that post, plus everything you've posted between then and my reply in post #7 that does not make it clear what you're trying to do.

macropod · #12 11-27-2015, 04:17 AM

No, there is no such Find expression.

PRA007 · #13 11-27-2015, 04:33 AM

So this is the end of the project then from my side.

Is there any way to distinguish between following two string and search accordingly to find result?

Code:

1
column 2 cell
WO 2015171641 A1¶
Some text¤

2
WO 2015171641 A1¶
Some text¶
US 2015328185 A1¶

macropod · #14 11-27-2015, 04:41 AM

Clearly the two are different, but which one do you want to exclude?

PRA007 · #15 11-27-2015, 05:33 AM

I want to search only case 1 pasted below only. As in my above code I have handled case 2 using your solution.

Code:

1
column 2 cell
WO 2015171641 A1¶
Some text¤

If found then I want to split(.Text, vbcr)(0) and run code provided by you.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Extracting Data from Word Documents	Atomizer	Word VBA	3	08-24-2015 04:49 PM
extracting data from word docs	stubevh	Word	2	03-04-2015 06:27 PM
Extracting data from excel	Eric855	Word	6	07-25-2013 08:02 AM
Extracting text from a Word Doc into Excel	dgcarlin	Word VBA	1	07-06-2012 05:46 PM
Extracting Contacts Data from Excel	Caesar	Outlook	1	05-08-2011 05:54 AM