Here is code that I used for a specific project; you may have to adapt it a
little to get it working for your needs. The directory path was in cell A1 in
one of the sheets, and it cycled Word files and extracted data from each. It
also extracts formfield data.
The person who created the document I was extracting used nested tables
(ugh), so this code takes that into account, if you have the same problem.
HTH,
Keith
Option Base 1
Public UseCol
Public WhichCol
Public SArr As Variant
Public PasteRow
Sub UseFFLDOnly()
Dim wdDoc As String
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim wTable As Word.Table
Dim tRangeText As String, tRange As Word.Range
Dim p As Long, r As Long
Dim cSht As Worksheet
UsePath = Sheet3.Range("A1").Value
wdDoc = Dir(path & "\*.doc*")
Do While wdDoc <> ""
'Open the document
Set wrdDoc = WdApp.Documents.Open(path & "\" & wdDoc)
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open(strPath)
WhichCol = 0
PasteRow1 = Find_Last(Sheet1) + 1
PasteRow2 = Find_Last(Sheet2) + 1
Dim ffld As Word.FormField
If wrdDoc.FormFields(1).Name = "EeName" Then
Set cSht = Sheet1
UseRowCount = PasteRow1
Else
Set cSht = Sheet2
UseRowCount = PasteRow2
End If
For Each ffld In wrdDoc.FormFields
WhichCol = WhichCol + 1
ConvertCol (WhichCol)
'Debug.Print ffld.Result
If UseRowCount > 2 Then
If cSht.Range(UseCol & 1).Value <> ffld.Name Then
MsgBox "Mismatched Field Name: Check for errors" &
Chr(13) & Chr(13) & _
"Row " & UseRowCount & " on Sheet " & cSht.Name
End If
End If
cSht.Range(UseCol & 1).Value = ffld.Name
cSht.Range(UseCol & UseRowCount).Value = ffld.Result
Next
wrdDoc.Close
'Get the next document
wdDoc = Dir()
Loop
MsgBox "Done", , "Processing completed"
End Sub
Sub CreateReport(path As String)
Dim wdDoc As String
Dim curDoc As Word.Document
'Get first document in directory
wdDoc = Dir(path & "\*.docx")
'Loop until we don't have anymore documents in the directory
Do While wdDoc <> ""
'Open the document
Set curDoc = WdApp.Documents.Open(path & "\" & wdDoc)
'Get comments
DoComments curDoc
'Get revisions
DoRevisions curDoc
'Close the document
curDoc.Close
'Get the next document
wdDoc = Dir()
Loop
End Sub
Private Function Find_Last(sht As Worksheet)
Find_Last = sht.Cells.Find(What:="*", After:=sht.Range("A1"),
LookAt:=xlPart, _
LookIn:=xlFormulas, SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, MatchCase:=False).Row
End Function
Private Function ConvertCol(SourceNum)
MyColNum = SourceNum
'==================================================================
'Translate Column header to usable letter as UseCol
ColMod = MyColNum Mod 26 'div column # by 26. Remainder is the
second letter
If ColMod = 0 Then 'if no remainder then fix value
ColMod = 26
MyColNum = MyColNum - 26
End If
intInt = MyColNum \ 26 'first letter
If intInt = 0 Then UseCol = Chr(ColMod + 64) Else _
UseCol = Chr(intInt + 64) & Chr(ColMod + 64)
'==================================================================
End Function
Sub Folder_Listing_Wrapper()
Const ParentFolderPath As String =
"C:\Users\Henry\Documents\Transfer\Work Files\Current Work\"
Call Folder_Listing(ParentFolderPath)
End Sub
Sub Folder_Listing(ParentFolderPath As String)
Dim FSO As Object, FolderSubFolder As Object, FolderFile As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each FolderSubFolder In FSO.GetFolder(ParentFolderPath).SubFolders
Debug.Print ParentFolderPath & FolderSubFolder.Name & "\"
Next FolderSubFolder
For Each FolderFile In FSO.GetFolder(ParentFolderPath).Files
Debug.Print ParentFolderPath & FolderFile.Name
Next FolderFile
End Sub
