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 (sample1.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
