Microsoft Office Forums - View Single Post - [Solved] How to transferring Word data to an Excel sheet

macropod · 02-25-2014, 01:34 AM

If you add content controls or formfields to your document so that the users can input the data into them, you can use Word's 'save data for forms' option to extract the data for import into Excel. Alternatively, you could use an Excel macro like the following to read the data from the Word documents; this is better than trying to push the data to Excel from each Word document. Simply run the macro, which has a folder browser you use to select the folder to process, and it will add the form data from all documents in the selected folder to the active worksheet.

Code:

Sub GetFormData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim WkSht As Worksheet, r As Long, c As Long
strFolder = GetFolder:If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document
Dim FmFld As Word.FormField, CCtrl As Word.ContentControl
Set WkSht = ActiveSheet
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
'Disable any auto macros in the documents being processed
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  r = r + 1
  Set wdDoc = wdApp.Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    c = 0
    For Each FmFld In .FormFields
      c = c + 1
      With FmFld
        Select Case .Type
          Case Is = wdFieldFormCheckBox
            WkSht.Cells(r, c) = .CheckBox.Value
          Case Else
            If IsNumeric(FmFld.Result) Then
              If Len(FmFld.Result) > 15 Then
                WkSht.Cells(r, c) = "'" & FmFld.Result
              Else
                WkSht.Cells(r, c) = FmFld.Result
              End If
            Else
              WkSht.Cells(r, c) = FmFld.Result
            End If
        End Select
      End With
    Next
    For Each CCtrl In .ContentControls
      With CCtrl
        Select Case .Type
          Case Is = wdContentControlCheckBox
            c = c + 1
            WkSht.Cells(i, j) = .Checked
          Case wdContentControlDate, wdContentControlDropdownList, wdContentControlRichText, wdContentControlText
            c = c + 1
            If IsNumeric(.Range.Text) Then
              If Len(.Range.Text) > 15 Then
                WkSht.Cells(r, c).Value = "'" & .Range.Text
              Else
                WkSht.Cells(r, c).Value = .Range.Text
              End If
            Else
              WkSht.Cells(r, c) = .Range.Text
            End If
          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

If you want to record the document's name as part of the data, change:
c = 0
to:
c = 1: WkSht.Cells(r, c) = strFile

For PC macro installation & usage instructions, see: Installing Macros