Import word form to excel macro

Hello,

I use this macro to import word form data to excel. I find this macro online. Macro works fine with form textfields, but in my form are some dropdown lists and macro in excel put some squares instead of values. Can someone help me, what should I change in code that will import dropdown list values to?

Here is macro:

Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim FmFld As Word.FormField
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
myFolder = "C:\Users\oddelek.a\Desktop\Testna"
Application.ScreenUpdating = False
If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
Range("A1") = "Vrstaporočila"
Range("A1").Font.Bold = True
Range("B1") = "Priimek"
Range("B1").Font.Bold = True
Range("C1") = "Ime"
Range("C1").Font.Bold = True
Range("D1") = "Rojstnipodatki"
Range("D1").Font.Bold = True
Range("E1") = "Datum"
Range("E1").Font.Bold = True
Range("F1") = "Ura"
Range("F1").Font.Bold = True
Range("G1") = "Izmena"
Range("G1").Font.Bold = True
Range("H1") = "Služba"
Range("H1").Font.Bold = True
Range("I1") = "Status"
Range("I1").Font.Bold = True
Range("J1") = "Mesto"
Range("J1").Font.Bold = True
Range("K1") = "Vrsta"
Range("K1").Font.Bold = True
i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.doc", vbNormal)

While strFile <> ""
i = i + 1
Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "" & strFile, AddToRecentFiles:=False, Visible:=False)
With myDoc
j = 0
For Each FmFld In .FormFields
j = j + 1
myWkSht.Cells(i, j) = FmFld.Range
Next
myWkSht.Columns.AutoFit
End With
myDoc.Close SaveChanges:=False
strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True

End Sub

Hello onsight,

In versions of Word after 2007, there are three types of control collections: FormField, InlineShapes (Active X), and the newest ContentControls.

The only types of InlineShapes that accept user input are TextBox, ComboBox, and ListBox.

Examples for Checking for different Collections...

Code:

---


                    ' // Check for Content Controls
                    With wdDoc.ContentControls(cnt)
                        Select Case .Type
                            Case Is = 0: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' Rich TextBox
                            Case Is = 1: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' Plain TextBox
                            Case Is = 3: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' ComboBox
                            Case Is = 4: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' DropDown List
                            Case Is = 6: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' Date Picker
                        End Select
                    End With
 
                    ' // Check for Active X Controls
                    If wdDoc.InlineShapes(cnt).Type = 5 Then
                        Select Case Split(wdDoc.InlineShapes(cnt).OLEFormat.progID, ".")(1)
                            Case Is = "TextBox", "ComboBox", "ListBox"
                                            Rng.Value = wdDoc.InlineShapes(cnt).OLEFormat.Object.Value
                                            Set Rng = Rng.Offset(0, 1)
                        End Select
                    End If

                    ' // Check for FormField Controls.
                    With wdDoc.FormFields(cnt)
                            Select Case .Type
                                Case Is = 70: Rng.Value = .TextInput.Format: Set Rng = Rng.Offset(0, 1)
                                Case Is = 71: Rng.Value = .CheckBox.Value: Set Rng = Rng.Offset(0, 1)
                                Case Is = 83: Rng.Value = .DropDown.Value: Set Rng = Rng.Offset(0, 1)
                            End Select
                    End With

---

Thank you for answer. I m not VBA specialist and I dont know, how to use your answer correctly. Can you show me on my macro, how I must change macro to import dropdown list values to? Please?

Quote:

---

Originally Posted by Leith Ross

Hello onsight,

In versions of Word after 2007, there are three types of control collections: FormField, InlineShapes (Active X), and the newest ContentControls.

The only types of InlineShapes that accept user input are TextBox, ComboBox, and ListBox.

Examples for Checking for different Collections...

Code:

---


                    ' // Check for Content Controls
                    With wdDoc.ContentControls(cnt)
                        Select Case .Type
                            Case Is = 0: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' Rich TextBox
                            Case Is = 1: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' Plain TextBox
                            Case Is = 3: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' ComboBox
                            Case Is = 4: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' DropDown List
                            Case Is = 6: Rng.Value = .Range.Text: Set Rng = Rng.Offset(0, 1)    ' Date Picker
                        End Select
                    End With
 
                    ' // Check for Active X Controls
                    If wdDoc.InlineShapes(cnt).Type = 5 Then
                        Select Case Split(wdDoc.InlineShapes(cnt).OLEFormat.progID, ".")(1)
                            Case Is = "TextBox", "ComboBox", "ListBox"
                                            Rng.Value = wdDoc.InlineShapes(cnt).OLEFormat.Object.Value
                                            Set Rng = Rng.Offset(0, 1)
                        End Select
                    End If

                    ' // Check for FormField Controls.
                    With wdDoc.FormFields(cnt)
                            Select Case .Type
                                Case Is = 70: Rng.Value = .TextInput.Format: Set Rng = Rng.Offset(0, 1)
                                Case Is = 71: Rng.Value = .CheckBox.Value: Set Rng = Rng.Offset(0, 1)
                                Case Is = 83: Rng.Value = .DropDown.Value: Set Rng = Rng.Offset(0, 1)
                            End Select
                    End With

---

---

Thank you for answer. I m not VBA specialist and I dont know, how to use your answer correctly. Can you show me on my macro, how I must change macro to import dropdown list values to? Please?

Hello onsight,

Are the only controls in the Word Document FormField TextBoxes and FormField DropDowns?

Quote:

---

Originally Posted by Leith Ross

Hello onsight,

Are the only controls in the Word Document FormField TextBoxes and FormField DropDowns?

---

Yes, only textfields and dropdown lists are in the document. This macro I copy paste from internet tutorial works fine, text fileds are imported to excel, dropdown list values are not. Can you help me?

Maybe https://www.gmayor.com/ExtractDataFromForms.htm will help?

Quote:

---

Originally Posted by gmayor

Maybe https://www.gmayor.com/ExtractDataFromForms.htm will help?

---

I work in hospital as nurse and I cant install anything on our computer, so the add on can be problem. I need this for analyzing incidents and patient falling of the bed in our hospital. So...there is no way to modify macro I send in my post? Like I said, macro do exactly what I need. I have form with text form fields and dropdown lists. Dropdown lists are populated depend in first dropdown list, so this single form can be used for several incidents.
When I import word form data with this macro in my post, all text fields are imported correctly, all dropdown fields are not imported. Instead of data excel put in columns squares. Is something missing in macro or what? I will be very grateful for help.

The extraction of formfield & content control data from Word to Excel has been discussed numerous times. See, for example:
http://www.vbaexpress.com/forum/show...l=1#post257696
and, further down in the same thread:
http://www.vbaexpress.com/forum/show...l=1#post291047

If these are legacy form fields as appears to be the case, change

Code:

---

myWkSht.Cells(i, j) = FmFld.Range

---

to

Code:

---

myWkSht.Cells(i, j) = FmFld.Result

---

Quote:

---

Originally Posted by gmayor

If these are legacy form fields as appears to be the case, change

Code:

---

myWkSht.Cells(i, j) = FmFld.Range

---

to

Code:

---

myWkSht.Cells(i, j) = FmFld.Result

---

---

Hello,

thank you, I change macro as you said and now all fields are imported to excel. But something else is now wrong. Now when I run macro, alert window show run-time error 5825, I select End and excel import only one file data, if I click debug, this line is yellow: myWkSht.Cells(i, j) = FmFld.Result.
And word program keep running in background. I send both files, so you can see for yourself.

I think I find a problem. Runtime error report every time, when word form is not completly filled. When one field is left empty, then macro stop importing data. Problem is, that form wil many times have some fields empty. Can someone know, how change macro that will skip empty fields and continue importing?

Quote:

---

Originally Posted by gmayor

Maybe https://www.gmayor.com/ExtractDataFromForms.htm will help?

---

I try this add on and have same problem like with macro...if form have empty fields, alert window for runtime error shows up. Import only ful filled forms.
Any solution for this?

You can either trap empty fields in your document or you can trap them in the extraction macro. With your original Excel code the following should work

Code:

---

Sub getWordFormData()Dim wdApp As Object
Dim myDoc As Object
Dim bStart As Boolean
Dim FmFld As Object
Dim oFSO As Object
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStart = True
    End If
    On Error GoTo 0
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    myFolder = Environ("USERPROFILE") & "\Desktop\Testna\"
    If Not oFSO.FolderExists(myFolder) Then GoTo lbl_Exit
    Application.ScreenUpdating = False
    Set myWkSht = ActiveSheet
    Range("A1") = "Vrstaporocila"
    Range("A1").Font.Bold = True
    Range("B1") = "Priimek"
    Range("B1").Font.Bold = True
    Range("C1") = "Ime"
    Range("C1").Font.Bold = True
    Range("D1") = "Rojstnipodatki"
    Range("D1").Font.Bold = True
    Range("E1") = "Datum"
    Range("E1").Font.Bold = True
    Range("F1") = "Ura"
    Range("F1").Font.Bold = True
    Range("G1") = "Izmena"
    Range("G1").Font.Bold = True
    Range("H1") = "Služba"
    Range("H1").Font.Bold = True
    Range("I1") = "Status"
    Range("I1").Font.Bold = True
    Range("J1") = "Mesto"
    Range("J1").Font.Bold = True
    Range("K1") = "Vrsta"
    Range("K1").Font.Bold = True
    i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
    strFile = Dir(myFolder & "*.doc", vbNormal)
    While strFile <> ""
        i = i + 1
        Set myDoc = wdApp.Documents.Open(FileName:=myFolder & strFile, AddToRecentFiles:=False, Visible:=False)
        With myDoc
            j = 0
            For Each FmFld In .FormFields
                j = j + 1
                On Error GoTo err_Handler
                myWkSht.Cells(i, j) = FmFld.Result
            Next
            myWkSht.Columns.AutoFit
        End With
        myDoc.Close SaveChanges:=False
        strFile = Dir()
    Wend
lbl_Exit:
    If bStart = True Then wdApp.Quit
    Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing: Set oFSO = Nothing
    Application.ScreenUpdating = True
    Exit Sub
err_Handler:
    If Err.Number = 5825 Then
        Resume Next
    Else
        MsgBox Err.Number & vbCr & Err.Description
        GoTo lbl_Exit
    End If
End Sub

---

Quote:

---

Originally Posted by gmayor

You can either trap empty fields in your document or you can trap them in the extraction macro. With your original Excel code the following should work

Code:

---

Sub getWordFormData()Dim wdApp As Object
Dim myDoc As Object
Dim bStart As Boolean
Dim FmFld As Object
Dim oFSO As Object
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Set wdApp = CreateObject("Word.Application")
        bStart = True
    End If
    On Error GoTo 0
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    myFolder = Environ("USERPROFILE") & "\Desktop\Testna\"
    If Not oFSO.FolderExists(myFolder) Then GoTo lbl_Exit
    Application.ScreenUpdating = False
    Set myWkSht = ActiveSheet
    Range("A1") = "Vrstaporocila"
    Range("A1").Font.Bold = True
    Range("B1") = "Priimek"
    Range("B1").Font.Bold = True
    Range("C1") = "Ime"
    Range("C1").Font.Bold = True
    Range("D1") = "Rojstnipodatki"
    Range("D1").Font.Bold = True
    Range("E1") = "Datum"
    Range("E1").Font.Bold = True
    Range("F1") = "Ura"
    Range("F1").Font.Bold = True
    Range("G1") = "Izmena"
    Range("G1").Font.Bold = True
    Range("H1") = "Služba"
    Range("H1").Font.Bold = True
    Range("I1") = "Status"
    Range("I1").Font.Bold = True
    Range("J1") = "Mesto"
    Range("J1").Font.Bold = True
    Range("K1") = "Vrsta"
    Range("K1").Font.Bold = True
    i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
    strFile = Dir(myFolder & "*.doc", vbNormal)
    While strFile <> ""
        i = i + 1
        Set myDoc = wdApp.Documents.Open(FileName:=myFolder & strFile, AddToRecentFiles:=False, Visible:=False)
        With myDoc
            j = 0
            For Each FmFld In .FormFields
                j = j + 1
                On Error GoTo err_Handler
                myWkSht.Cells(i, j) = FmFld.Result
            Next
            myWkSht.Columns.AutoFit
        End With
        myDoc.Close SaveChanges:=False
        strFile = Dir()
    Wend
lbl_Exit:
    If bStart = True Then wdApp.Quit
    Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing: Set oFSO = Nothing
    Application.ScreenUpdating = True
    Exit Sub
err_Handler:
    If Err.Number = 5825 Then
        Resume Next
    Else
        MsgBox Err.Number & vbCr & Err.Description
        GoTo lbl_Exit
    End If
End Sub

---

---

Thank you soooo much. Works like....!!! Thanks again.