Data from Word form to Excel?

  • Thread starter Thread starter SandyT
  • Start date Start date
S

SandyT

I am trying to dump data from the fields of a Word form
into an Excel spreadsheet. I am using Word 2002 and Excel
2002.

Basically, I am receiving completed Word forms from
multiple people, and I'd like to keep everyone's
information in one spreadsheet. I can cut and paste if
necessary, but I was hoping for a more automated option.

Does anyone know if this is this possible?
Thanks,
SandyT
 
Are these documents that contain form fields, such as text boxes, and
option buttons?

If so, you can save all the Word files in one folder, as field text
only, and import the data into Excel.

1. Save all the completed Word forms as text (in Word, choose
Tools>Options, and on the Save tab, add a check mark to
'Save data only for forms')
2. Place all the files in one folder ("c:\TestFiles\" in this example)
3. Open the Excel file in which you want to collect the data
("MyImports.xls" in this example, on sheet "FormData")
4. Run a macro similar to the following, which loops through all the
files in the designated folder, and copies the form data to the
master file

'============================
Sub ImportTextFiles()
'code for looping through file in folder
'stolen from post by Dave Peterson
Dim myFiles() As String
Dim i As Integer
Dim myFile As String
Dim myFolder As String
Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range
Dim r As Long
'this sheet collects the form data
Set ws = Workbooks("MyImports.xls").Sheets("FormData")

Application.DisplayAlerts = False
Application.ScreenUpdating = False

myFolder = "c:\TestFiles\"
If Right(myFolder, 1) <> "\" Then
myFolder = myFolder & "\"
End If

myFile = Dir(myFolder & "*.txt")

If myFile = "" Then
MsgBox "no text files found"
Exit Sub
End If

Do While myFile <> ""
i = i + 1
ReDim Preserve myFiles(1 To i)
myFiles(i) = myFile
myFile = Dir()
Loop

For i = LBound(myFiles) To UBound(myFiles)
r = ws.Range("A1").End(xlDown).Offset(1, 0).Row
Set rng = ws.Range("A" & r)
Workbooks.OpenText Filename:=myFolder & myFiles(i), _
Origin:=437, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, Comma:=False, Space:=False, _
Other:=False, FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
Set wb = ActiveWorkbook
ActiveSheet.Rows("1:1").Copy Destination:=rng
wb.Close savechanges:=False
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
'============================
 
Back
Top