Building a Report from Multiple Folders and Word Docs

[arroway]

Hello Gurus!

I'm trying to put together a report. I wish there was a way of doing a mail merge but I think this is a bit more complicated than that.

Here's what I have:
Completed word Forms with named formfields in 3 folders (C:\MyPath\Folder1, C:\MyPath\Folder2, and C:\MyPath\Folder3).

What I need:
I'm looking to pull the data from 7 form fields (TextField8, TextField12, TextField13, TextField20, TextField21, TextField25, TextField26) from each Word (.doc) file and placed onto a word document, one after the other (All fields, line break, next record--no page breaks). One of the fields (TextField15 is a date field and I'd like to be able to put in a range (include records from 05/12/2012 to 09/15/2014).

I'm not sure that can be done with a Mail Merge. I'd love to know how if it's possible. And if not, I'm hoping this might be done with VB but I'd need help writing something like that. Can someone help?

Thank you,
Dax

[HansV]

This will require VBA - mail merge only works with a single file as data source, not with multiple files.

Are the completed forms the only Word documents in those folders, or are there other Word documents too?
Is there an objection against placing all the forms in a single folder (without other documents)?

[arroway]

The completed forms are the only forms in those folders. And for this report's sake, I could certainly create a dummy folder and copy over all the records into that one folder. This isn't something that will be run that often.

[HansV]

The following is air code, I haven't actually tested it.

Code: Select all

Sub ImportFields()
    Dim docSrc As Document
    Dim docTrg As Document
    Dim strPath As String
    Dim strFile As String
    Dim varField As Variant
    Dim datField15 As Date
    ' Prompt for folder
    With Application.FileDialog(4)  ' msoFileDialogFolderPicker
        If .Show Then
            strPath = .SelectedItems(1)
        Else
            Beep
            Exit Sub
        End If
    End With
    ' You can replace the above with something like strPath = "C:\MyFolder" if you prefer
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    ' Hide what's going on
    Application.ScreenUpdating = False
    ' Create target document
    Set docTrg = Documents.Add
    ' First document in folder
    strFile = Dir(strPath & "*.doc*")
    ' Loop through documents
    Do While strFile <> ""
        ' Open document
        Set docSrc = Documents.Open(FileName:=strPath & strFile, AddToRecentFiles:=False)
        ' Get value of TextField15
        datField15 = DateValue(docSrc.FormFields("TextyField15").Result)
        ' Check for date range
        If datField15 >= #5/12/2012# And datField15 <= #9/15/2014# Then
            ' Process fields
            For Each varField In Array("TextField8", "TextField12", "TextField13", _
                    "TextField20", "TextField21", "TextField25", "TextField26")
                ' Insert field result into target document
                docTrg.Content.InsertAfter docSrc.FormFields(varField).Result & " "
            Next varField
            ' Add a paragraph break
            docTrg.Content.InsertParagraphAfter
        End If
        docSrc.Close SaveChanges:=False
        ' On to the next document
        strFile = Dir
    Loop
    ' Show the result
    Application.ScreenUpdating = True
End Sub

[arroway]

Thanks Hans! I'll try this out and let you know how it goes. --Dax

[arroway]

HI Hans,
This code works great! Just what I need but I'd like to add lables and linebreaks and I'm wondering where these go and how to add them.

So when I run the macro it gives me:
Textfield8, TextField2, TextField13, Texfield20, TextField21, TextField25, Textfield26

Just what I asked for. But upon further review, it's a bit difficut to read so how I'd like it to display is:

Location: TextField8, Name: TextField12 TextField13, DOB: TextField21 (linebreak)
Comments: TextField25 (linebreak)
Supporting Info: TextField26

What needs to be added to get it to do this? The lables are fixed text. I'm guessing the added info needs to go in this line:
For Each varField In Array("TextField8", "TextField12", "TextField13", _
"TextField20", "TextField21", "TextField25", "TextField26")

Am I close?
--Dax

[arroway]

Applying H4 formatting to the lables would be cool too but I don't want to push it. ;-)

[HansV]

This version doesn't apply formatting:

Code: Select all

Sub ImportFields()
    Dim docSrc As Document
    Dim docTrg As Document
    Dim strPath As String
    Dim strFile As String
    Dim datField15 As Date
    Dim strText As String
    ' Prompt for folder
    With Application.FileDialog(4)  ' msoFileDialogFolderPicker
        If .Show Then
            strPath = .SelectedItems(1)
        Else
            Beep
            Exit Sub
        End If
    End With
    ' You can replace the above with something like strPath = "C:\MyFolder" if you prefer
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    ' Hide what's going on
    Application.ScreenUpdating = False
    ' Create target document
    Set docTrg = Documents.Add
    ' First document in folder
    strFile = Dir(strPath & "*.doc*")
    ' Loop through documents
    Do While strFile <> ""
        ' Open document
        Set docSrc = Documents.Open(FileName:=strPath & strFile, AddToRecentFiles:=False)
        ' Get value of TextField15
        datField15 = DateValue(docSrc.FormFields("TextyField15").Result)
        ' Check for date range
        If datField15 >= #5/12/2012# And datField15 <= #9/15/2014# Then
            ' Process fields
            strText = "Location: " & docSrc.FormFields("TextField8").Result & _
                ", Name: " & docSrc.FormFields("TextField12").Result & " " & _
                docSrc.FormFields("TextField13").Result & ", DOB: " & _
                docSrc.FormFields("TextField21").Result & Chr(11) & _
                "Comments: " & docSrc.FormFields("TextField25").Result & Chr(11) & _
                "Supporting Info: " & docSrc.FormFields("TextField26").Result & vbCr
        End If
        docSrc.Close SaveChanges:=False
        ' On to the next document
        strFile = Dir
    Loop
    ' Show the result
    Application.ScreenUpdating = True
End Sub

[arroway]

Hi Hans,
Thanks for your help again. This code seems to run. I see all the documents opening and closing but once it's done I'm left with the original document and a new document with nothing either of them. They're both blank.

[HansV]

Oops, sorry, I forgot one essential line

Code: Select all

Sub ImportFields()
    Dim docSrc As Document
    Dim docTrg As Document
    Dim strPath As String
    Dim strFile As String
    Dim datField15 As Date
    Dim strText As String
    ' Prompt for folder
    With Application.FileDialog(4)  ' msoFileDialogFolderPicker
        If .Show Then
            strPath = .SelectedItems(1)
        Else
            Beep
            Exit Sub
        End If
    End With
    ' You can replace the above with something like strPath = "C:\MyFolder" if you prefer
    If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If
    ' Hide what's going on
    Application.ScreenUpdating = False
    ' Create target document
    Set docTrg = Documents.Add
    ' First document in folder
    strFile = Dir(strPath & "*.doc*")
    ' Loop through documents
    Do While strFile <> ""
        ' Open document
        Set docSrc = Documents.Open(FileName:=strPath & strFile, AddToRecentFiles:=False)
        ' Get value of TextField15
        datField15 = DateValue(docSrc.FormFields("TextyField15").Result)
        ' Check for date range
        If datField15 >= #5/12/2012# And datField15 <= #9/15/2014# Then
            ' Process fields
            strText = "Location: " & docSrc.FormFields("TextField8").Result & _
                ", Name: " & docSrc.FormFields("TextField12").Result & " " & _
                docSrc.FormFields("TextField13").Result & ", DOB: " & _
                docSrc.FormFields("TextField21").Result & Chr(11) & _
                "Comments: " & docSrc.FormFields("TextField25").Result & Chr(11) & _
                "Supporting Info: " & docSrc.FormFields("TextField26").Result & vbCr
            docTrg.Content.InsertAfter strText
        End If
        docSrc.Close SaveChanges:=False
        ' On to the next document
        strFile = Dir
    Loop
    ' Show the result
    Application.ScreenUpdating = True
End Sub

[arroway]

Yeay!! That's the one! THANK YOU!!!