Microsoft Office Forums

Go Back   Microsoft Office Forums > >

Reply
 
Thread Tools Display Modes
  #1  
Old 11-23-2015, 05:32 AM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 32bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Smile Extracting data from excel document using word

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.

Last edited by PRA007; 11-23-2015 at 10:00 PM.
Reply With Quote
  #2  
Old 11-25-2015, 12:47 AM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 32bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

I Think Its very lengthy and tedious to answer this question as a whole.
Reply With Quote
  #3  
Old 11-25-2015, 04:54 AM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 32bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

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.
Reply With Quote
  #4  
Old 11-25-2015, 04:19 PM
macropod's Avatar
macropod macropod is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Quote:
Originally Posted by PRA007 View Post
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 View Post
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?
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #5  
Old 11-25-2015, 08:55 PM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 32bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

Quote:
Originally Posted by macropod View Post
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 View Post
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
Reply With Quote
  #6  
Old 11-26-2015, 02:43 AM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

The Problem Looks like
Code:
If .Find.Found Then
and

Code:
With .Cell(i, 5).Range
are not linked. I may be wrong.
Reply With Quote
  #7  
Old 11-26-2015, 05:12 AM
macropod's Avatar
macropod macropod is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #8  
Old 11-26-2015, 08:45 PM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

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

Quote:
Originally Posted by macropod View Post
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.
Reply With Quote
  #9  
Old 11-26-2015, 10:33 PM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

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.
Reply With Quote
  #10  
Old 11-27-2015, 12:53 AM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

Is there any Wild card character or something to find end of cell mark?
Reply With Quote
  #11  
Old 11-27-2015, 04:17 AM
macropod's Avatar
macropod macropod is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

No, there is no such Find expression.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #12  
Old 11-27-2015, 04:28 AM
macropod's Avatar
macropod macropod is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Quote:
Originally Posted by PRA007 View Post
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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #13  
Old 11-27-2015, 04:33 AM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

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¶
Reply With Quote
  #14  
Old 11-27-2015, 04:41 AM
macropod's Avatar
macropod macropod is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

Clearly the two are different, but which one do you want to exclude?
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]
Reply With Quote
  #15  
Old 11-27-2015, 05:33 AM
PRA007's Avatar
PRA007 PRA007 is offline Extracting data from excel document using word Windows 7 64bit Extracting data from excel document using word Office 2010 32bit
Competent Performer
Extracting data from excel document using word
 
Join Date: Dec 2014
Location: Ahmedabad, Gujrat, India
Posts: 145
PRA007 is on a distinguished road
Default

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.
Reply With Quote
Reply

Tags
excel vba, word vba

Thread Tools
Display Modes


Similar Threads
Thread Thread Starter Forum Replies Last Post
Extracting data from excel document using word Extracting Data from Word Documents Atomizer Word VBA 3 08-24-2015 04:49 PM
Extracting data from excel document using word extracting data from word docs stubevh Word 2 03-04-2015 06:27 PM
Extracting data from excel document using word Extracting data from excel Eric855 Word 6 07-25-2013 08:02 AM
Extracting data from excel document using word 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

Other Forums: Access Forums

All times are GMT -7. The time now is 02:46 AM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2024, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2024 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft