Hi,
I made some modifications to this code; however, I still needs some help to get it perform the tasks I need it to do.
It finds the data and populates the spreadsheet, but how do I get the program to iterate through hundreds of word documents, both *.doc and *.docx?
I referenced a few books and online resources, but the code I tried open word on screen and had to be manually closed. My local library's books are from the late 90's, the syntax has likely changed. Is there a method for it to run in the background and iterate through the files in a folder? Please help!
Thank you,
Vekmaa
Option Explicit
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
'let's select the WORD doc
Set FD = Application.FileDialog(msoFileDialogOpen)
FD.Show
If FD.SelectedItems.Count <> 0 Then
FName = FD.SelectedItems(1)
Else
Exit Sub
End If
' open Word application and load doc
Set WApp = CreateObject("Word.Application")
' WApp.Visible = True
Set WDoc = WApp.Documents.Open(FName)
'=====================================================================
' go home and search
WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "File: "
'move cursor from find to final data item
' WApp.Selection.MoveDown Unit:=5, Count:=1
WApp.Selection.MoveRight Unit:=1, Count:=1
'the miracle happens here
WApp.Selection.MoveRight Unit:=1, Count:=8, Extend:=1
'grab and put into excel
Set WDR = WApp.Selection
ExR(1, 1) = WDR ' place at Excel cursor
'=====================================================================
'repeat
WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
'WApp.Selection.Find.Execute "File: "
'move cursor from find to final data item
WApp.Selection.MoveDown Unit:=wdLine, Count:=2
'WApp.Selection.MoveRight Unit:=1, Count:=1
'the miracle happens here
WApp.Selection.MoveRight Unit:=1, Count:=16, Extend:=1
'grab and put into excel
Set WDR = WApp.Selection
ExR(1, 2) = WDR ' place in cell right of Excel cursor
'======================================================================
'repeat
WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
'WApp.Selection.Find.Execute "File: "
'move cursor from find to final data item
WApp.Selection.MoveDown Unit:=wdLine, Count:=3
WApp.Selection.MoveRight Unit:=1, Count:=1
'the miracle happens here
WApp.Selection.MoveRight Unit:=wdWord, Count:=4, Extend:=wdExtend
'grab and put into excel
Set WDR = WApp.Selection
ExR(1, 3) = WDR ' place in cell right of Excel cursor
'======================================================================
'repeat
WApp.Selection.HomeKey Unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "Licence No. "
'move cursor from find to final data item
' WApp.Selection.MoveDown Unit:=5, Count:=1
WApp.Selection.MoveRight Unit:=1, Count:=1
'the miracle happens here
WApp.Selection.MoveRight Unit:=1, Count:=6, Extend:=1
'grab and put into excel
Set WDR = WApp.Selection
ExR(1, 4) = WDR ' place in cell right of Excel cursor
'======================================================================
WDoc.Close
WApp.Quit
End Sub