Import Word Form Fields into excel

[TiffanyW]

I have the following Macro that imports form fields from word into Excel taken from a previously closed post. When it exports it always puts the data on the next row in excel, instead I want it to always override the previous data and put the new data in row 2 after my headers. I have played around and can't seem to figure out how to accomplish this.


Sub GetFormData()
'Note: this code requires a reference to the Word object model
'To do this, go to Tools|References in the VBE, then scroll down to the Microsoft Word entry and check it.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, CCtrl As Word.ContentControl, FmFld As Word.FormField
Dim strFolder As String, strFile As String, WkSht As Worksheet, i As Long, j As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
With CCtrl
Select Case .Type
Case Is = wdContentControlCheckBox
j = j + 1
WkSht.Cells(i, j).Value = .Checked
Case wdContentControlDate, wdContentControlDropdownList, wdContentControlRichText, wdContentControlText
j = j + 1
WkSht.Cells(i, j).Value = .Range.Text
Case Else
End Select
End With
Next
For Each FmFld In ActiveDocument.FormFields
j = j + 1
With FmFld
Select Case .Type
Case Is = wdFieldFormCheckBox
WkSht.Cells(i, j).Value = .Checked
Case Else
WkSht.Cells(i, j).Value = .Result
Case Else
End Select
End With
Next
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub


Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[macropod]

So how would the macro determine what's old and what's new?

PS: When posting code, please use the code tags, indicated by the# button on the posting menu. Without them, your code has lost whateverstructure it had.

[gmayor]

If you want to replace everything in the sheet with the data then make the following changes. Note that as you are working with content controls also, ensure that the macro can only process xml documents or you will have to add error correction. It might be simpler just to change doc to docx as shown

Set WkSht = ActiveSheet
WkSht.Rows("2:" & Rows.Count).ClearContents
i = 1
strFile = Dir(strFolder & "\*.docx", vbNormal)

[TiffanyW]

This is exactly what I am looking for. I need to Clear the contents in Row 2 then import the new form fields into row 2. I have tried this code and now I am getting the error "1004:Application-defined or object-defined error". I have tried playing around with it but nothing seems to work.

[gmayor]

My guess is that you have not set a reference to the Word object library. The following doesn't need such a reference and does work, albeit with reservations about the fact that there is no error handling whatsoever to ensure that the documents processed all match, or that they even contain content controls or form fields. If there happens to be a document in the folder that doesn't match the parameters it is likely to crash. I would also caution against checking form fields and content controls in the same process. The two are not really compatible with one another. I have also replaced the getfolder function as it is a pain to navigate with a large folder structure.


Option Explicit

Sub GetFormData()
'Note: this code DOES NOT require a reference to the Word object model
Dim wdApp As Object
Dim wdDoc As Object
Dim CCtrl As Object
Dim FmFld As Object
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, i As Long, j As Long

Application.ScreenUpdating = False

strFolder = BrowseForFolder("Select folder containing the form documents")
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
WkSht.Rows("2:" & Rows.Count).ClearContents
i = 1
strFile = Dir(strFolder & "\*.docx", vbNormal)

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
End If
On Error GoTo 0

While strFile <> ""
i = i + 1
Set wdDoc = wdApp.Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
j = 0
For Each CCtrl In .ContentControls
j = j + 1
WkSht.Cells(i, j) = CCtrl.Range.Text
Next
For Each FmFld In .FormFields
j = j + 1
WkSht.Cells(i, j) = FmFld.Result
Next
End With
wdDoc.Close 0
strFile = Dir()
DoEvents
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub

Private Function BrowseForFolder(Optional strTitle As String) As String
'Graham Mayor
'strTitle is the title of the dialog box
Dim fDialog As FileDialog
On Error GoTo err_Handler
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = strTitle
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then GoTo err_Handler:
BrowseForFolder = fDialog.SelectedItems.Item(1) & Chr(92)
End With
lbl_Exit:
Exit Function
err_Handler:
BrowseForFolder = vbNullString
Resume lbl_Exit
End Function