快崩溃了，如何从几千个相同的WORD文件中提取相应的文字和数值到EXCEL里。

mikezhu58

不好意思，我搞错了，我可没有审核的权利。请问一下老师，为什么我把代码用在新建的excel或者word里都不能使用呢。 C:\Documents and Settings\Administrator.CHINA-126FC5BD7\My Documents\My Pictures

loquat

Sub 提取内容_MeThee()  '只生成Excel，不自动保存。
On Error Resume Next     '这里加一行试试
Application.ScreenUpdating = False

loquat

应该是放在word里面运行的。。。

mikezhu58

loquat 发表于 2015-3-10 20:09
Sub 提取内容_MeThee()  '只生成Excel，不自动保存。
On Error Resume Next     '这里加一行试试
Applica ...

首先感谢老师的指导。照老师的讲解加上了这一句还是不行，问题依旧。但我这是用在提取一个文件夹下的所有基本相同的word文档并生成一个excel文档，不是一个一个打开word再提取。我想这个宏应该用在一个excel里，是吧老师。请老师帮助更改一下以使能处理我那些非常烦累的工作，再次感谢。

loquat

不好意思，还是未测试，一开始未看清问题。
1.再次重申，要放到word里面使用
2.自己修改文件夹地址
3.自己在工程里引用Microsoft Scripting Runtime
   就是scrrun.dll，如果提示出错就注册一下，开始-运行-"regsvr32 scrrun.dll"
4.代码完成后会生成新Excel文件汇总结果，请保存为xlsx文件，否则有可能不能保存，所以office2003有可能运行此代码的保存部分会有问题

1. Sub 提取内容_MeThee()  '只生成Excel，不自动保存。
   
2. Application.ScreenUpdating = False
   
3. On Error Resume Next
   
4. Dim aCount&, aFolder$, arr, brr, i&, j&
   
5. Dim aTable As Word.Table, aDoc As Word.Document
   
6. '遍历部分
   
7. aFolder = """" & "C:\Users\Administrator\Desktop\我的word文件地址" & """"  '设置自己文件夹地址，不要修改引号部分
   
8. With CreateObject("WScript.Shell")
   
9.        arr = Split(.Exec(Environ$("comspec") & " /c dir " & Folder & "*.doc /s /a:-d /b | findstr /v " & """" & "~" & """").StdOut.ReadAll, vbCrLf)  '黑窗口，一闪即过
   
10. End With
    
11. Dim 姓名 As New Scripting.Dictionary
    
12. Dim 身份证 As New Scripting.Dictionary
    
13. Dim 电话 As New Scripting.Dictionary
    
14. Dim 户籍地 As New Scripting.Dictionary
    
15. Dim 居住地 As New VScripting.Dictionary
    
16. Dim 文件名 As New Scripting.Dictionary
    
17. 姓名(1) = "姓名"
    
18. 身份证(1) = "身份证"
    
19. 电话(1) = "电话"
    
20. 户籍地(1) = "户籍地"
    
21. 居住地(1) = "居住地"
    
22. 文件名(1) = "文件名"
    
23. j = 1
    
24. Lk = LBound(arr): Uk = UBound(arr)
    
25. For k = Lk To Uk   '提取内容部分
    
26.     With Word.Documents.Open(arr(k))
    
27.         aCount = .Tables.Count
    
28.         For i = 1 To aCount
    
29.             Set aTable = .Tables(i)
    
30.             brr = Split(aTable.Range.Text, Chr(7))
    
31.             If UBound(brr) = 108 Then
    
32.                 j = j + 1
    
33.                 姓名.Add j, Left(brr(13), Len(brr(13)) - 1)
    
34.                 身份证.Add j, Left(brr(39), Len(brr(39)) - 1)
    
35.                 电话.Add j, Left(brr(8), Len(brr(8)) - 1)
    
36.                 户籍地.Add j, Left(brr(44), Len(brr(44)) - 1)
    
37.                 居住地.Add j, Left(brr(49), Len(brr(49)) - 1)
    
38.                 文件名.Add j, arr(k)
    
39.                 j = j + 1
    
40.                 姓名.Add j, Left(brr(66), Len(brr(66)) - 1)
    
41.                 身份证.Add j, Left(brr(92), Len(brr(92)) - 1)
    
42.                 电话.Add j, Left(brr(61), Len(brr(61)) - 1)
    
43.                 户籍地.Add j, Left(brr(97), Len(brr(97)) - 1)
    
44.                 居住地.Add j, Left(brr(102), Len(brr(102)) - 1)
    
45.                 文件名.Add j, arr(k)
    
46.             End If
    
47.         Next
    
48.     End With
    
49. Next
    
50. Set aExcel = CreateObject("Excel.Application")
    
51. aExcel.Visible = True
    
52. Set aBook = aExcel.Workbooks.Add
    
53. Set aSheet = aBook.Worksheets("Sheet1")
    
54. aCount = 姓名.Count
    
55. '保存部分
    
56. aSheet.Range("A1").Resize(aCount, 1) = aExcel.Transpose(姓名.Items)
    
57. aSheet.Range("B1").Resize(aCount, 1) = aExcel.Transpose(身份证.Items)
    
58. aSheet.Range("C1").Resize(aCount, 1) = aExcel.Transpose(电话.Items)
    
59. aSheet.Range("D1").Resize(aCount, 1) = aExcel.Transpose(户籍地.Items)
    
60. aSheet.Range("E1").Resize(aCount, 1) = aExcel.Transpose(居住地.Items)
    
61. aSheet.Range("F1").Resize(aCount, 1) = aExcel.Transpose(文件名.Items)
    
62. Application.ScreenUpdating = True
    
63. End Sub
    

复制代码

mikezhu58

loquat 发表于 2015-3-11 11:17
不好意思，还是未测试，一开始未看清问题。
1.再次重申，要放到word里面使用
2.自己修改文件夹地址

谢谢老师，但经过测试，已在工程里引用Microsoft Scripting Runtime，但问题如下:

loquat

就不编辑贴子了，多了个V

mikezhu58

loquat 发表于 2015-3-12 14:13
就不编辑贴子了，多了个V

老师你好，去掉V后，宏能运行。只几秒后，弹出excel窗口；除表格抬头外，为什么不能提取任何实际数值。

loquat

自己测试了一下，能用了。到底还是水平不行，必须要自己调试才能发出来。。。

mikezhu58

非常感谢老师的悉心指导，但我使用还是出现问题。