求各位大侠帮帮我，如何实现从Word中批量提取数据到Excel中

zhanglei1371

首先，打开党员信息的word文件，alt＋F11━→粘贴代码进去：

1. Sub sbc()
   
2.     Dim arr, cx As Object
   
3.     Dim ex As Object
   
4.     Set ex = GetObject(, "Excel.application")
   
5.     Set cx = ex.workbooks("dyxxhzb.xls").sheets(1) ’Excel文件名。必须一致
   
6.     Set re = CreateObject("vbscript.regexp")
   
7.     re.Global = 1
   
8.     re.Pattern = "姓名[：\s]*(\S+).+?性别[：\s]*(\S+).+?民" & _
   
9.         "族[：\s]*(\S+).+?公民身份证号[：\s]*(\S+).+?出生日期" _
   
10.         & "[：\s]*(\S+).+?学历（参照《学历代码》填写相应代码）" & _
    
11.         "[：\s]*(\S+).+?人员类别[：\s]*(\S+).+?所在党支部（填写全称）" _
    
12.         & "[：\s]*(\S+).+?加入党组织日期[：\s]*(\S+).+?转为正式党员日期" & _
    
13.         "[：\s]*(\S+).+?工作岗位（参照《工作岗位代码》填写相应代码）" & _
    
14.         "[：\s]*(\S+).+?联系电话（手机号）[：\s]*(\d+).+?（固定电话）" & _
    
15.         "[：\s]*(\d+).+?家庭住址（具体到门牌号）[：\s]*(\S+).+?党籍状态" & _
    
16.         "[：\s]*(\S+).+?是否为失联党员[：\s]*(\S+).+?失去联系日期[：\s]*?(\S+)是否为流动党员（由流出地党组织负责采集）" & _
    
17.         "[：\s]*(\S+).+?外出流向：(.*?)\r"
    
18.     Set Ma = re.Execute(ActiveDocument.Range.Text)
    
19.     i = 4
    
20.     For Each g In Ma
    
21.         i = i + 1
    
22.         j = 1
    
23.         For Each sb In g.submatches
    
24.             j = j + 1
    
25.             cx.Cells(i, j) = sb
    
26.         Next
    
27.     Next
    
28. End Sub
    

复制代码

然后打开Excel文件，将你的excel解除保护（你懂的），运行以上代码。
最后将不对应的列手动调整下即可。

lzqlaj

论坛里有从word 提数据到excel，不过那个是从word表格中提取，楼主这种情况没有到过。

lzqlaj

zhanglei1371 发表于 2017-7-27 11:38
首先，打开党员信息的word文件，alt＋F11━→粘贴代码进去：
然后打开Excel文件，将你的excel解除保护（你 ...

正则表达式，值得学习。

lzqlaj

Sub sbc()
      .........  
       xb = cx.Cells(i, 3)
        mz = cx.Cells(i, 4)
        rq = cx.Cells(i, 6)
        xl = cx.Cells(i, 7)
        lb = cx.Cells(i, 8)
        cx.Cells(i, 3) = cx.Cells(i, 9)
        cx.Cells(i, 4) = cx.Cells(i, 5)
        cx.Cells(i, 5) = xb
        cx.Cells(i, 6) = mz
        cx.Cells(i, 7) = rq
        cx.Cells(i, 8) = xl
        cx.Cells(i, 9) = lb
        ........
    Next

lzqlaj

见截图，无需手动调整。。。

ammyc

请解释下代码第23行的“g.submatches”的用法

jiaxinl

不知道大家有没有发现   失去联系日期 后面不管有没有数据  提取到的都是 "16."正则表达式入门与提高---VBA平台的正则学习参考资料
http://club.excelhome.net/forum.php?mod=viewthread&tid=1128647&extra=&mobile=2

Sub s()

Dim arr, cx As Object
Dim ex As Object
Set ex = GetObject(, "Excel.application")
Set cx = ex.workbooks("dyxxhzb.xls").sheets(1) 'Excel
Set re = CreateObject("vbscript.regexp")
re.Global = 1
re.Pattern = "姓名[：\\s]*(\\S+).+?性别[：\\s]*(\\S+).+?民族[：\\s]*(\\S+).+?公民身份证号[：\\s]*(\\S+).+?出生日期" & _
"[：\\s]*(\\S+).+?学历（参照《学历代码》填写相应代码）[：\\s]*(\\S+).+?人员类别[：\\s]*(\\S+).+?所在党支部（填写全称）" & _
"[：\\s]*(\\S+).+?加入党组织日期[：\\s]*(\\S+).+?转为正式党员日期" & _
"[：\\s]*(\\S+).+?工作岗位（参照《工作岗位代码》填写相应代码）" & _
"[：\\s]*(\\S+).+?联系电话（手机号）[：\\s]*(\\d+).+?（固定电话）" & _
"[：\\s]*(\\d+).+?家庭住址（具体到门牌号）[：\\s]*(\\S+).+?党籍状态" & _
"[：\\s]*(\\S+).+?是否为失联党员[：\\s]*(\\S+).+?失去联系日期[：\\s]*?(\\S+)是否为流动党员（由流出地党组织负责采集）" & _
"[：\\s]*(\\S+).+?外出流向：(.*?)\\r"

Set Ma = re.Execute(ActiveDocument.Range.Text)
  i = 4
For Each g In Ma
  i = i + 1
  j = 1
cx.Cells(i, j) = i - 4   '填写序号列
  For Each sb In g.submatches
    j = j + 1
    '调整栏位顺序
    If j = 3 Then
      cx.Cells(i, j + 2) = sb
    ElseIf j = 4 Then
      cx.Cells(i, j + 2) = sb
    ElseIf j = 5 Then
      cx.Cells(i, j - 1) = sb
    ElseIf j = 6 Then
      cx.Cells(i, j + 1) = sb
    ElseIf j = 7 Then
      cx.Cells(i, j + 1) = sb
    ElseIf j = 8 Then
      cx.Cells(i, j + 1) = sb
    ElseIf j = 9 Then
      cx.Cells(i, j - 6) = sb
    ElseIf sb = "16." Then
      cx.Cells(i, j) = ""
    Else
      cx.Cells(i, j) = sb
    End If
  Next sb
Next g
End Sub

dwgzy

这个工作有点意思

星星草

感谢zhanglei1371分享，学习了

coverne

学习下这个问题