ExcelTip.Net留存知识帖 ---【注：附件之前被网盘供应商清空后，现已修复-现已修复-现已修复为本地下载！】
现在位置：首页 > E问E答 > Excel VBA > 如何利用vba批量从word文档中提取所需信息？（正则方式）

如何利用vba批量从word文档中提取所需信息？（正则方式）

作者：绿色风 分类： 时间：2022-08-17 浏览：131
楼主
kevinchengcw		 Q: 如何利用vba批量从word文档中提取所需信息？（正则方式）
A: 代码及解释如下：
  1. Sub test()
  2. Dim Dic As Object, FN$, Arr, Arrt, Arrt2, Rule, RegEx As Object, mMatch, Str$, Str2$, StrT$, N&, I&, T&, C%, D%, All&
  3. FN = Dir(ThisWorkbook.Path & "\*.doc")  '循环提取当前目录下的全部word文档(本例仅针对03版文档,其他版本可参考使用"\*.doc?")
  4. All = 0  '初始化统计文件数量为零
  5. Do While FN <> ""  '第一次循环用于计数文件数量
  6.     All = All + 1
  7.     FN = Dir
  8. Loop
  9. Set RegEx = CreateObject("vbscript.regexp")  '创建正则项目
  10. With RegEx
  11.     .Global = True  '全局有效
  12.     .MultiLine = True  '多行有效
  13.     .ignorecase = True  '忽略大小写
  14. End With
  15. Set Dic = CreateObject("scripting.dictionary")  '创建字典项目,用于替换推荐人代码为指定人名(本例为示例,实际使用中可以将item项替换成对应人名)
  16. With Dic
  17.     .Add "A", "一"
  18.     .Add "B", "二"
  19.     .Add "C", "三"
  20.     .Add "D", "四"
  21.     .Add "E", "五"
  22.     .Add "F", "六"
  23.     .Add "G", "七"
  24. End With
  25. With CreateObject("word.application")  '创建word进程,用于操作word文档
  26.     .Visible = False  '隐藏操作
  27.     .AutomationSecurity = msoAutomationSecurityForceDisable  '打开文档时不启用宏
  28.     .DisplayAlerts = False  '关闭警告信息
  29.     ReDim Arr(1 To All + 1, 1 To 14)  '定义输出的excel表格
  30.     Arrt = Split("序号,姓名,性别,户籍,出生年月,毕业学校,专业,学历,工作年龄,最近三家单位及时长,推荐职位,待遇要求,推荐时间,推荐人", ",")   '分配表头对应信息
  31.     For N = LBound(Arrt) To UBound(Arrt)  '将表头信息写入结果数组
  32.         Arr(1, N + 1) = Arrt(N)
  33.     Next N
  34.     FN = Dir(ThisWorkbook.Path & "\*.doc")  '第二次循环,用于提取各个文件操作
  35.     T = 2  '初始化数据写入结果数组的起始行数(第一次已被表头占用)
  36.     Rule = Array("基本情况：([\s\S]+)(?=二、教育..：)", "教育..：([\s\S]+)(?=三、工作..：)", "工作经历：([\s\S]+)(?=四、优势..：)", "推荐说明：([\s\S]+)(?=调研单位：)")  '创建正则表达式规则数组,用于提取各个大项文本
  37.     Do While FN <> ""  '当存在有效文件时循环提取
  38.         With .documents.Open(ThisWorkbook.Path & "\" & FN)   '打开文件
  39.             Str = .Range.Text  '读取文档文字内容
  40.             .Close False  '关闭文档(不保存)
  41.         End With
  42.         Arr(T, 14) = Dic(Left(FN, 1))  '先写入推荐人信息
  43.         With RegEx
  44.             Arr(T, 1) = T - 1  '写入序号
  45.             For N = LBound(Rule) To UBound(Rule)  '循环各个正则规则表达式项目
  46.                 .Pattern = Rule(N)  '将规则赋值给正则项目
  47.                 Str2 = ""  '初始化数据文本为空
  48.                 If Rule(N) Like "基本*" Then  '通过规则判断取得的结果区段,并进行最终信息提取
  49.                     If .test(Str) Then
  50.                         Str2 = .Execute(Str)(0).submatches(0)
  51.                         .Pattern = "\s*(\S?)：\s*"
  52.                         Str2 = .Replace(Str2, "$1 ")
  53.                         .Pattern = "[\r\n]+"
  54.                         Str2 = WorksheetFunction.Trim(.Replace(Str2, "  "))
  55.                         Arrt = Split(Str2, " ")
  56.                         Arr(T, 2) = Arrt(1)
  57.                         Arr(T, 3) = Arrt(3)
  58.                         Arr(T, 4) = Arrt(11)
  59.                         Arr(T, 5) = Arrt(5)
  60.                     End If
  61.                 ElseIf Rule(N) Like "教育*" Then
  62.                     If .test(Str) Then
  63.                         Str2 = .Execute(Str)(0).submatches(0)
  64.                         .Pattern = "[\r\n]+"
  65.                         Str2 = WorksheetFunction.Trim(.Replace(Str2, "  "))
  66.                         Arrt = Split(Str2, " ")
  67.                         Arr(T, 6) = Arrt(1)
  68.                         Arr(T, 7) = Arrt(2)
  69.                         Arr(T, 8) = Arrt(3)
  70.                     End If
  71.                 ElseIf Rule(N) Like "工作*" Then
  72.                     If .test(Str) Then
  73.                         Str2 = WorksheetFunction.Trim(.Execute(Str)(0).submatches(0))
  74.                         .Pattern = "\（[一二三四五六七**十]+\）(.+?)(?=[\r\n])"
  75.                         StrT = ""
  76.                         I = Year(Date)
  77.                         C = 0
  78.                         D = 0
  79.                         For Each mMatch In .Execute(Str2)
  80.                             If C < 3 Then
  81.                                 Arrt2 = Split(Replace(mMatch.submatches(0), " ", ""), "—")
  82.                                 If Arrt2(UBound(Arrt2)) Like "*至今*" Then
  83.                                     D = Round((Year(Date) + Month(Date) / 12) - (Val(Arrt2(0)) + ((12 - Val(Split(Arrt2(0), "年")(1))) / 12)), 1)
  84.                                 Else
  85.                                     D = Round((Val(Arrt2(UBound(Arrt2))) + Val(Split(Arrt2(UBound(Arrt2)), "年")(1)) / 12) - (Val(Arrt2(0)) + ((12 - Val(Split(Arrt2(0), "年")(1))) / 12)), 1)
  86.                                 End If
  87.                                 StrT = StrT & Split(mMatch.submatches(0), " ")(UBound(Split(mMatch.submatches(0), " "))) & "(" & D & "年)"
  88.                                 'If C < 2 Then StrT = StrT & vbNewLine
  89.                                 C = C + 1
  90.                             End If
  91.                             If Val(Split(mMatch.submatches(0), " ")(0)) < I Then I = Val(mMatch.submatches(0))
  92.                         Next mMatch
  93.                         Arr(T, 9) = Year(Date) - I
  94.                         Arr(T, 10) = StrT
  95.                     End If
  96.                 ElseIf Rule(N) Like "推荐*" Then
  97.                     If .test(Str) Then
  98.                         Str2 = WorksheetFunction.Trim(.Execute(Str)(0).submatches(0))
  99.                         .Pattern = "建议贵.*司授予\s*\S+\s*(\S+)(?=\s*职务)"
  100.                         If .test(Str2) Then Arr(T, 11) = .Execute(Str2)(0).submatches(0)
  101.                         If Str2 Like "*待遇*面谈*" Then
  102.                             Arr(T, 12) = "面谈"
  103.                         ElseIf Str2 Like "*期望*待遇不低于现有*" Then
  104.                             .Pattern = "原公司\S*待遇是\s*((\d+\.)*\d+.*)(?=元)"
  105.                             If .test(Str2) Then Arr(T, 12) = ">" & .Execute(Str2)(0).submatches(0)
  106.                         Else
  107.                             .Pattern = "期望待遇是\s*((\d+\.)*\d+.*?)(?=\/)"
  108.                             If .test(Str2) Then Arr(T, 12) = .Execute(Str2)(0).submatches(0)
  109.                         End If
  110.                     End If
  111.                 End If
  112.                 .Pattern = "(\d+)年(\d+)月(\d+)日\s*$"
  113.                 If .test(Str) Then
  114.                     With .Execute(Str)(0)
  115.                         Arr(T, 13) = .submatches(0) & "." & .submatches(1) & "." & .submatches(2)
  116.                     End With
  117.                 End If
  118.             Next N
  119.         End With
  120.         T = T + 1  '数据行下移一行
  121.         FN = Dir  '循环到下一文件
  122.     Loop
  123.     .AutomationSecurity = msoAutomationSecurityByUI   '设置打开word文档时询问是否启用宏状态
  124.     .Quit  '退出word进程
  125. End With
  126. With [a2].Resize(UBound(Arr), UBound(Arr, 2))
  127.     .Value = Arr  '结果数组写入单元格区域中
  128.     With Intersect(Rows(2), .Cells)  '设置标题行字体及颜色
  129.         .Font.Color = vbRed
  130.         .Font.Bold = True
  131.     End With
  132.     On Error Resume Next  '设置容错
  133.     .SpecialCells(xlCellTypeBlanks) = "未知"  '空白单元格写入"未知"字样(如果没有空白单元格则会因上一句的容错而继续执行,避免了程序中断)
  134. End With
  135. Columns.AutoFit  '列宽自适应
  136. Columns("F:K").ColumnWidth = 18  '对可能会过宽的F:K列设置固定列宽
  137. Cells.VerticalAlignment = xlCenter  '文字剧中显示
  138. Set RegEx = Nothing  '清空创建的项目
  139. Set Dic = Nothing
  140. End Sub
因程序提取的文件书写时存在一定的不规范性,为使程序能尽可能多的处理各种情况,需根据数据采集的实际情况不断丰富完善提取规则.
详见附件及素材源帖.
JLHZ.rar
2楼
JOYARK1958		 謝謝提供學習下載中
3楼
猴子		 我知道正则是很厉害的，我正在学习字典，希望能得到你的帮助

免责声明

有感于原ExcelTip.Net留存知识的价值及部分知识具有的时间限定性因素， 经与ExcelTip.Net站长Apolloh商议并征得其同意， 现将原属ExcelTip.Net的知识帖采集资料于本站点进行展示， 供有需要的人士查询使用，也慰缅曾经的论坛时代。 所示各个帖子的原作者如对版权有异议， 可与本人沟通提出，或于本站点留言，我们会尽快处理。 在此，感谢ExcelTip.Net站长Apolloh的支持，感谢本站点所有人**绿色风（QQ:79664738)**的支持与奉献，特此鸣谢！
------本人网名**KevinChengCW（QQ:1210618015)**原ExcelTip.Net总版主之一

猜您喜欢
评论列表
搜索

鄂ICP备2021011689号-2

powered by emlog pro Theme By 蓝叶

sitemap