Extract Certain Text from Word into Excel Using VBA

Hi,
i'm new to VBA and i'm learning now.
My requirement is to match the word PROC or PRIC from a word document and move the next strings to excel under corresponding headers.
for (e.g) my word document (sample.docx) contains
PROC-1801
PROC-1901
PRIC-1801
PRIC-1901

my excel (sample.xlsm) contains the heading
PROC PRIC

code need to check the word PROC and move the text 1801, 1901 to excel under the heading PROC like below
PROC
1801
1901

Have gone through some of the online site and come up with the below code. this code doesn't give any error but the results were not coming in sample1 spreadsheet.

Code is given below:

Sub GrabUsage()
Dim FName As String, FD As FileDialog
Dim WApp As Object, WDoc As Object, WDR As Object
Dim ExR As Range

Set ExR = Selection
' current location in Excel Sheet

'Declare a string variable to access our Word document
Dim strDocName As String
'Error handling
On Error Resume Next
'Activate Word it is already open
Set WApp = GetObject(, “Word.Application”)
If Err.Number = 429 Then
Err.Clear
'Create a Word application if Word is not already open
Set WApp = CreateObject(“Word.Application”)
End If
WApp.Visible = True
strDocName = "C:\vb\sample.docx"
'Check relevant directory for relevant document
'If not found then inform the user and close program
If Dir(strDocName) = “” Then
MsgBox "The file " & strDocName & vbCrLf & "was not found in the folder path" & vbCrLf & "C:\vb\.", vbExclamation, "Sorry, that document name does not exist."
Exit Sub
End If

WApp.Activate

Set WDoc = WApp.Documents(strDocName)

If WDoc Is Nothing Then Set WDoc = WApp.Documents.Open(strDocName)
WDoc.Activate


' go home and search
WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "PROC"

' move cursor from find to final data item
' WApp.Selection.MoveDown Unit:=5, Count:=1
WApp.Selection.MoveRight Unit:=2, Count:=1
'the miracle happens here
WApp.Selection.MoveRight Unit:=2, Count:=1, Extend:=1

' grab and put into excel
Set WDR = WApp.Selection
Dim rownum As Integer
Dim columnum As Integer
Dim Tble As Integer
columnum = 1
rownum = 1
With WDoc
'Tble = WDoc.ActiveDocument.Words.Count
Tble = 5

If Tble = 0 Then

MsgBox "PROC not found in the Word document", vbExclamation, "No PROC found"
Exit Sub
End If
'start the looping process to access tables and their rows, columns
For i = 1 To Tble
ExR(rownum, columnum) = WDR
'insert in next row
rownum = rownum + 1
Next


' repeat
WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "PRIO"
WApp.Selection.MoveRight Unit:=2, Count:=2
WApp.Selection.MoveRight Unit:=2, Count:=2, Extend:=1

Set WDR = WApp.Selection
Dim rownum1 As Integer
Dim columnum1 As Integer
Dim Tble1 As Integer
columnum1 = 2
rownum1 = 1


'Tble1 = WDoc.ActiveDocument.Words.Count
Tble1 = 2
If Tble1 = 0 Then

MsgBox "PRIO not found in the Word document", vbExclamation, "No PRIO found"
Exit Sub
End If
'start the looping process to access tables and their rows, columns
For j = 1 To Tble1
ExR(rownum1, columnum1) = WDR
'insert in next row
rownum1 = rownum1 + 1
Next

End With


MsgBox "program was successful", vbExclamation, "successful"


WDoc.Close
WApp.Quit

End Sub

It's impossible to tell for sure what's going on from your code, because you're using Selections & Moves in Word. Furthermore, having lines like:
Tble1 = 5
followed by:
If Tble1 = 0 Then
and:
Tble1 = 2
followed by:
If Tble1 = 0 Then
are pointless, since the If tests must always return False. Try something along the lines of the code below:

Sub GrabUsage()
Application.ScreenUpdating = False
'Note: A reference to the Word Object Library is required.

'Declare a string variable to access our Word document
Const strDocName As String = "C:\vb\sample.docx"

'Check relevant directory for relevant document. If not found then inform the user and exit
If Dir(strDocName) = "" Then
  MsgBox "The file " & strDocName & vbCrLf & "was not found", vbExclamation, "Sorry, that document does not exist."
  Exit Sub
End If

' current location in Excel Sheet
Dim xlRng As Range: Set xlRng = ActiveCell

Dim wdApp As New Word.Application, wdDoc As Word.Document, wdRng As Word.Range, r As Long

With wdApp
  'Set .Visible = False once the code runs correctly
  .Visible = True
   'Set Visible:=False once the code runs correctly
  Set wdDoc = .Documents.Open(strDocName, ReadOnly:=True, AddToRecentFiles:=False, Visible:=True)
  With wdDoc
    With .Range
      With .Find
        .ClearFormatting
        .Text = "PROC-[0-9]{4}"
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Execute
      End With
      If .Find.Found = False Then
        MsgBox "PROC not found in the Word document", vbExclamation, "No PROC found"
      Else
        r = 0
        Do While .Find.Found = True
          r = r + 1
          xlRng.Offset(r, 0).Value = Split(.Text, "-")(1)
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
      End If
    End With
    With .Range
      With .Find
        .ClearFormatting
        .Text = "PRIO-[0-9]{4}"
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Execute
      End With
      If .Find.Found = False Then
        MsgBox "PRIO not found in the Word document", vbExclamation, "No PRIO found"
      Else
        r = 0
        Do While .Find.Found = True
          r = r + 1
          xlRng.Offset(r, 1).Value = Split(.Text, "-")(1)
          .Collapse wdCollapseEnd
          .Find.Execute
        Loop
      End If
    End With
    .Close False
  End With
  .Quit
End With
Application.ScreenUpdating = True
End Sub

Cross-posted at: http://www.vbaexpress.com/forum/show...xcel-Using-VBA
Please read Excel Forum's Cross-Posting policy in rule 8: http://www.excelforum.com/forum-rule...rum-rules.html

Admin note: I have tried to add tags to post #1, but the text disappears on edit

Originally Posted by sandy666

Hi Ford,
Copy whole text from post, edit post, paste text from the clipboard, add tags

I thought about doing that, but figured if members saw that an admin or mod had tried, it would be OK - I have added the tags