利用ExcelVBA提取word中的数据

sw3392787

      各位大神好，向各位请教个问题。在此允许我啰嗦描述！
      平时工作为管理报名人员的信息，而日常工作需要将报名信息表word文档（空表），让学员进行填写。回收回来后需要将这些文档内的个人信息（如姓名、性别、身份证号码、手机号、QQ、邮箱等信息）进行汇总登记，登记入一个Excel表内。
      所以请教各位大神，怎么处理。Word是多个文档（一名学员一个文档），Excel仅一个为汇总信息内容，而Excel的表头有多个，我需要提取的信息如下图所示标黄部分

表头标黄部分则为需要从word文档提取

而word信息内容如下所示：

word数据格式

     相信以上内容对各位大神来说不难，我在论坛也看到过类似提取简历信息的，但是这里有个小难题，就是费用以及班次的提取，由于word表格的关系可能比较难，希望大神在给出方案是考虑下，如果没法解决，那就算了。
     谢谢各位了，跪求帮助！
     详细的参加附件，附件内容包括3个word个人信息表，以及1个Excel汇总表！ 提取数据.zip (386.73 KB, 下载次数: 428)

2018-4-3 11:55 上传

点击文件名下载附件

182197315

楼主把excel和word中的对应关系用相同的颜色标出来，写代码会快捷地多

Moneky

楼主，每当这个时候我都要给我自己的工具Doc2Xls打广告，我的Doc2Xls可以完美解决。

opiona

1.     Set WordApp = CreateObject("word.application")
   
2.     Set SHX = Worksheets("Sheet1")
   
3.     ARX = Split("1,1,1,6", ",")    '//所在Word表格 行数，个数和顺序和Excel列对应
   
4.     BRX = Split("3,5,7,3", ",")    '//所在Word表格 列数
   
5.     CRX = Split("6,9,10,11", ",")  '//在Excel中放到第几列
   
6.    
   
7.     FileArr = FileAllArr(ThisWorkbook.Path, "*.DOC?", ThisWorkbook.Name, True, False)
   
8.     For i = 0 To UBound(FileArr)
   
9.    
   
10.         WordApp.Visible = False  '关闭word文档的显示
    
11.         Set Worddoc = WordApp.Documents.Open(FileArr(i))
    
12.         Set WordTable = Worddoc.Tables(1) '指向第一张WORD表格
    
13.         
    
14.         Rem 每个需要的单元格
    
15.         For X = 0 To UBound(ARX)
    
16.             Set Cell = WordTable.Cell(Val(ARX(X)), Val(BRX(X)))
    
17.             If Not Cell Is Nothing Then     '如果单元格存在
    
18.                 SHX.Cells(i + 2, Val(CRX(X))).Value = Replace(Replace(Replace(Replace(Cell.Range.Text, Chr(7), ""), Chr(10), ""), Chr(13), ""), vbCrLf, "")
    
19.             End If
    
20.         Next
    
21.         
    
22.         Rem 搜索：培训费    2000       收款人
    
23.         Set Cell = WordTable.Cell(9, 2)
    
24.         Str费用 = Replace(Replace(Replace(Replace(Cell.Range.Text, Chr(7), ""), Chr(10), ""), Chr(13), ""), vbCrLf, "")
    
25.         SHX.Cells(i + 2, 21).Value = GetRegStr(Str费用, "[0-9.]+", 0)
    
26.         
    
27.         Rem 南山 福田 龙华 宝安 龙岗班
    
28.         STR1 = "南山,福田,龙华,宝安,龙岗班"
    
29.         With Worddoc.Content.Find
    
30.             .Highlight = True
    
31.             Do While .Execute
    
32.             Debug.Print "|" & .Parent.Text & "|"
    
33.                 If InStr(STR1, Replace(Replace(.Parent.Text, "(", ""), " ", "")) > 0 Then
    
34.                     SHX.Cells(i + 2, 23).Value = Replace(Replace(.Parent.Text, "(", ""), " ", "")
    
35.                     Exit Do
    
36.                 End If
    
37.             Loop
    
38.         End With
    
39.         
    
40.         WordApp.Visible = True   '关闭word文档的显示
    
41.         Worddoc.Close False
    
42.     Next
    
43.     WordApp.Quit
    
44.     Set Worddoc = Nothing

复制代码

opiona

200.rar (420.23 KB, 下载次数: 1124)

2018-4-4 07:53 上传

点击文件名下载附件

sw3392787

opiona 发表于 2018-4-4 07:53

非常感谢回答，同时答案很用心，里面各个都备注了解释，解决问题的同时方便我继续研究改进，谢谢了

sw3392787

Moneky 发表于 2018-4-3 21:05
楼主，每当这个时候我都要给我自己的工具Doc2Xls打广告，我的Doc2Xls可以完美解决。

昨晚找到你的那个工具，尝试了下。不知道是版本不对还是怎么回事？总是提示什么word文档第一行第一列（姓名）与Excel不符，第一行第二列………………巴拉巴拉，没研究明白

sw3392787

182197315 发表于 2018-4-3 20:02
楼主把excel和word中的对应关系用相同的颜色标出来，写代码会快捷地多

您的意思是指，比如把Excel的第2行，第1列是姓名将其标红，然后同时在word对应姓名那里也标红对吗？以此类推，比如Excel性别变黄，word文档也同时标黄对吧？

sw3392787

opiona 发表于 2018-4-4 07:53

暂时还没研究懂代码，在此请教，好像身份证号码、毕业院校等没有提取到？这些是没些代码还是提取过程出错？
另外本人添加多几个word文档在excel 的同个目录下，确实也能提取数据，但是个别word中的性别、年龄也会出现提取出来为空白的情况。

Moneky

sw3392787 发表于 2018-4-4 12:21
昨晚找到你的那个工具，尝试了下。不知道是版本不对还是怎么回事？总是提示什么word文档第一行第一列（姓 ...

不需要导入的格子清空，你看看我的示例文档就知道了。