[已解决]求高手们个从word提取数据到excel的代码，谢谢了，急呀

excel米

江湖救急，等着要呢。。先谢过高手们了
要求是这样的：将word文档的文本内容控件和组合内容控件的内容提取到excel的指定单元格。先些过高手们了，最好能调取当前文件夹的所有文档，要是这样很麻烦的话，就一个也可以。。。。谢谢 了

最佳答案

月排行榜 / 总排行榜

suye1010

2015-1-5 18:32

1. Dim EAPP,WAPP,TempWb,i,ConControl,Shell,ObjectPath,FolderPath,FSO,FSOFolder,FSOFile
   
2. On Error resume next
   
3. Set EAPP=CreateObject("Excel.Application")
   
4. EAPP.Visible=True
   
5. Set Tempwb=EAPP.workbooks.Add
   
6. Set WAPP=CreateObject("WORD.Application")
   
7. Set Shell=CreateObject("Shell.Application")
   
8. Set ObjectPath=Shell.BrowseForFolder(0, "请选择Word文件所在的文件夹", 0, 0)
   
9. If ObjectPath Is Nothing Then
   
10. Wscript.Quit
    
11. End If
    
12. FolderPath=ObjectPath.Self.Path
    
13. Set FSO=CreateObject("Scripting.FileSystemObject")
    
14. Set FSOFolder=FSO.GetFolder(FolderPath)
    
15. For Each FSOFile In FSOFolder.Files
    
16. i=i+1
    
17. j=0
    
18. WAPP.Documents.open(FSOFile.Path)
    
19. For Each ConControl in WAPP.ActiveDocument.ContentControls
    
20.         j=j+1
    
21.         TempWb.sheets(1).cells(i,j)=ConControl.Range
    
22. Next
    
23. WAPP.ActiveDocument.Close
    
24. Next
    
25. Msgbox "已完成"&FolderPath&"Word文档的汇总"
    
26. WAPP.Quit

复制代码

跳转到最佳答案楼层

excel米

这是附件，，，急等救命，，谢谢大侠们了

suye1010

1. Dim EAPP,WAPP,TempWb,i,ConControl,Shell,ObjectPath,FolderPath,FSO,FSOFolder,FSOFile
   
2. On Error resume next
   
3. Set EAPP=CreateObject("Excel.Application")
   
4. EAPP.Visible=True
   
5. Set Tempwb=EAPP.workbooks.Add
   
6. Set WAPP=CreateObject("WORD.Application")
   
7. Set Shell=CreateObject("Shell.Application")
   
8. Set ObjectPath=Shell.BrowseForFolder(0, "请选择Word文件所在的文件夹", 0, 0)
   
9. If ObjectPath Is Nothing Then
   
10. Wscript.Quit
    
11. End If
    
12. FolderPath=ObjectPath.Self.Path
    
13. Set FSO=CreateObject("Scripting.FileSystemObject")
    
14. Set FSOFolder=FSO.GetFolder(FolderPath)
    
15. For Each FSOFile In FSOFolder.Files
    
16. i=i+1
    
17. j=0
    
18. WAPP.Documents.open(FSOFile.Path)
    
19. For Each ConControl in WAPP.ActiveDocument.ContentControls
    
20.         j=j+1
    
21.         TempWb.sheets(1).cells(i,j)=ConControl.Range
    
22. Next
    
23. WAPP.ActiveDocument.Close
    
24. Next
    
25. Msgbox "已完成"&FolderPath&"Word文档的汇总"
    
26. WAPP.Quit

复制代码

excel米

suye1010 发表于 2015-1-5 18:32

我怎么找不到VBS文件呢，老师，，谢谢了。。。。能不能直接excel文档里弄个按钮直接运行啊，谢谢了。。。。。。火烧眉毛了

excel米

那个文本内容控件在代码里面怎么 写啊，，，比如我用对话框调取出来，比如msgbox textbox1.value
msgbox  XXXX   

芐雨

1. Sub t()
   
2.     Dim Wd As Object
   
3.     Dim myPath$, myFile$, i&, j&
   
4.     Dim arr(1 To 1000, 1 To 20) As String
   
5.     ActiveSheet.UsedRange.Offset(1).ClearContents
   
6.     Application.ScreenUpdating = False
   
7.     On Error Resume Next
   
8.     Set Wd = CreateObject("WORD.Application")
   
9.     myPath = ThisWorkbook.Path & ""
   
10.     myFile = Dir(myPath & "*.doc")
    
11.     Do While myFile <> ""
    
12.         Wd.Documents.Open (myPath & myFile)
    
13.         i = i + 1: j = 0
    
14.         For Each ConControl In Wd.ActiveDocument.ContentControls
    
15.             j = j + 1
    
16.             arr(i, j) = ConControl.Range
    
17.         Next
    
18.         Wd.ActiveDocument.Close
    
19.         myFile = Dir
    
20.     Loop
    
21.     Wd.Quit
    
22.     Range("A2").Resize(i, 20) = arr
    
23.     Application.ScreenUpdating = True
    
24.     MsgBox "已完成"
    
25. End Sub

复制代码

参考3楼，帮你修改了一下，还有，你的文件不止四个控件，如2号
150105.zip (51.95 KB, 下载次数: 9)

2015-1-5 20:11 上传

点击文件名下载附件

excel米

芐雨 发表于 2015-1-5 20:13
参考3楼，帮你修改了一下，还有，你的文件不止四个控件，如2号

我这个为什么不行啊，，，着急死了，好像很卡一样，最后跳出这么个对话框

excel米

麻烦大侠了

芐雨

我测试没有问题，2010的，你关了所有的excel,word的进程，更来一次试试

excel米

芐雨 发表于 2015-1-5 21:09
我测试没有问题，2010的，你关了所有的excel,word的进程，更来一次试试

还是一样的，任务管理器也看了，还有没有别的办法呀，谢谢大家了