word调查表数据抽取

johncabin · 发表于 2010-11-15 15:07

word调查表数据抽取
我有很多如附件那样用窗体设计的问卷，填写的内容如何高效的抽取到excel里？
拜托高手编个东西。

Admin · 发表于 2010-11-17 12:30

很遗憾通知楼上朋友，您的帖子在24小时之内没有任何回复！

通常情况下，本论坛发布的主题帖会在8小时被回复或处理。您的帖子在24小时之内未被回复，其中的原因可能是：

1、问题表述不清、模棱两可，难以理解，帮助者被搞晕了，夺帖而出；
2、没有上传必要的附件，或附件被遗忘在某个角落；
3、发帖提问时，语气带棱角、带挑衅，不幸被列入不受欢迎的帖子；
4、所提问题不成立，或提不合理的要求，乐于助人者使出“走为上”之计；
5、话题较偏、较冷或者发布到了不合适的版块，暂时无人问津，顾影自怜。

为了提高您的问题解决效率，我们推荐您阅读以下文章：
* 如何发表新话题和上传附件：http://club.excelhome.net/thread-45649-1-1.html
* 发帖的技巧：http://club.excelhome.net/thread-176339-1-1.html
* EH技术论坛的最佳学习方法：http://club.excelhome.net/thread-117862-1-1.html

johncabin · 发表于 2010-11-17 13:32

我还是想自己顶一下，问题还是比较清楚的，如果用手工方法，把word保存窗体域内容到txt文档，再在excel里分列，可以解决，但是还是需要一个一个调查表处理（每个表格手工处理完大概20秒），我这里有1200多份，这样就耗时了，有达人是否可以编VBA？

sylun · 发表于 2010-11-17 18:37

可试试如下代码（只针对活动文档）：

Sub test()
'依次提取活动文档中的窗体域数据
Dim myField As FormField, i As Byte, r As Integer
Dim AppExcel As Object, WSheet As Object
On Error Resume Next
Application.ScreenUpdating = False
'如果Excel已运行，则数据添加在当前的Excel文档活动工作表，否则新建Excel文档
Set AppExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set AppExcel = CreateObject("Excel.Application")
AppExcel.Workbooks.Add
Err.Clear
End If
AppExcel.Visible = True
Set WSheet = AppExcel.ActiveWorkbook.ActiveSheet
r = WSheet.UsedRange.Row + WSheet.UsedRange.Rows.Count - 1
For Each myField In ActiveDocument.FormFields
i = i + 1
WSheet.Rows(r + 1).Cells(i).Value = myField.Result
Next
Set AppExcel = Nothing
Application.ScreenUpdating = True
End Sub

复制代码

johncabin · 发表于 2010-11-17 20:56

感谢sylun的VBA，调试后能正常解决问题，非常感谢！只是速度有点慢？能看能否完善一下程序，就是把某个文件夹下的所有调查表的数据（有1000多份）一起抽取出来吗，您的方法确实很好！希望能改进、

sylun · 发表于 2010-11-18 08:48

原帖由 johncabin 于 2010-11-17 20:56 发表
感谢sylun的VBA，调试后能正常解决问题，非常感谢！只是速度有点慢？能看能否完善一下程序，就是把某个文件夹下的所有调查表的数据（有1000多份）一起抽取出来吗，您的方法确实很好！希望能改进、

程序修改如下，可试试。请不要将程序存放于问卷文档中，处理速度可能与原调查问卷文档内存占用情况有关。

Sub test2()
'批量提取指定文档中的窗体域数据
Dim myDialog As FileDialog, myItem As Variant, myDoc As Document
Dim myField As FormField, i As Byte, r As Integer
Dim AppExcel As Object, st As Single
On Error Resume Next
Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
With myDialog
.Title = "请选择需处理的所有文档"
.Filters.Clear
.Filters.Add "所有 WORD 文件", "*.doc", 1
.AllowMultiSelect = True
If .Show <> -1 Then Exit Sub
End With
st = Timer
'如果Excel已运行，则数据添加在当前的Excel文档活动工作表，否则新建Excel文档
Set AppExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set AppExcel = CreateObject("Excel.Application")
AppExcel.Workbooks.Add
AppExcel.Visible = True
Err.Clear
End If
AppExcel.Application.ScreenUpdating = False
With AppExcel.ActiveWorkbook.ActiveSheet
r = .UsedRange.Row + .UsedRange.Rows.Count - 1
For Each myItem In myDialog.SelectedItems '在所有选取项目中循环
Set myDoc = Documents.Open(FileName:=myItem, Visible:=False)
For Each myField In myDoc.FormFields
i = i + 1
.Rows(r + 1).Cells(i).Value = myField.Result
Next
i = 0
r = r + 1
myDoc.Close False
Next
End With
AppExcel.Application.ScreenUpdating = True
Set AppExcel = Nothing
MsgBox "提取完毕！用时：" & Format(Timer - st, 0) & "秒。"
End Sub

复制代码

johncabin · 发表于 2010-11-18 22:40

谢谢sylun，您的VBA解决我的大问题，用时3小时把1200份全部抽取出来了，您帮我了大忙，不知如何感谢！

johncabin · 发表于 2010-11-19 08:18

sylun您好！您的VBA代码有时候点了没反应，不知道是什么原因（原来是可以用的，后来就不执行了）

sylun · 发表于 2010-11-19 15:41

试了一下新附件，没发现什么问题，可提取。是一点反应也没有吗，连最后的弹出“提取完毕”等内容都没有？确实不行，请具体描述一下具体情形。

vonstore · 发表于 2011-12-4 15:06

很强大，很实用！！！！一定要好好学习一下

		自动登录	找回密码
密码			免费注册

[求助] word调查表数据抽取

〖Excel Home友情提示〗