我要文库申报
查看: 5799|回复: 7
如何利用vba批量从word文档中提取所需信息？（正则方式）
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次管理次数 次
网站名称: Excel技巧网 | Excel专家栖息谷 | 微软中文技术社区合作伙伴站内采编:
署名作者: KevinChengCW
版权声明: 版权归本站与作者共有 除本站官方外非作者本人转载须经许可并注明出处
适用版本: 03以前版本&
语言环境: 简体中文
学习方法: 掌握Excel技巧的关键是动手操作
下载 ≠ 知识
免费注册成为本站会员，享用更多功能，结识更多Office办公高手！
才可以下载或查看，没有帐号？
Q: 如何利用vba批量从word文档中提取所需信息？（正则方式）
A: 代码及解释如下：Sub test()
Dim Dic As Object, FN$, Arr, Arrt, Arrt2, Rule, RegEx As Object, mMatch, Str$, Str2$, StrT$, N&, I&, T&, C%, D%, All&
FN = Dir(ThisWorkbook.Path & &\*.doc&)&&'循环提取当前目录下的全部word文档(本例仅针对03版文档,其他版本可参考使用&\*.doc?&)
All = 0&&'初始化统计文件数量为零
Do While FN && &&&&'第一次循环用于计数文件数量
& & All = All + 1
& & FN = Dir
Loop
Set RegEx = CreateObject(&vbscript.regexp&)&&'创建正则项目
With RegEx
& & .Global = True&&'全局有效
& & .MultiLine = True&&'多行有效
& & .ignorecase = True&&'忽略大小写
End With
Set Dic = CreateObject(&scripting.dictionary&)&&'创建字典项目,用于替换推荐人代码为指定人名(本例为示例,实际使用中可以将item项替换成对应人名)
With Dic
& & .Add &A&, &一&
& & .Add &B&, &二&
& & .Add &C&, &三&
& & .Add &D&, &四&
& & .Add &E&, &五&
& & .Add &F&, &六&
& & .Add &G&, &七&
End With
With CreateObject(&word.application&)&&'创建word进程,用于操作word文档
& & .Visible = False&&'隐藏操作
& & .AutomationSecurity = msoAutomationSecurityForceDisable&&'打开文档时不启用宏
& & .DisplayAlerts = False&&'关闭警告信息
& & ReDim Arr(1 To All + 1, 1 To 14)&&'定义输出的excel表格
& & Arrt = Split(&序号,姓名,性别,户籍,出生年月,毕业学校,专业,学历,工作年龄,最近三家单位及时长,推荐职位,待遇要求,推荐时间,推荐人&, &,&)& &'分配表头对应信息
& & For N = LBound(Arrt) To UBound(Arrt)&&'将表头信息写入结果数组
& && &&&Arr(1, N + 1) = Arrt(N)
& & Next N
& & FN = Dir(ThisWorkbook.Path & &\*.doc&)&&'第二次循环,用于提取各个文件操作
& & T = 2&&'初始化数据写入结果数组的起始行数(第一次已被表头占用)
& & Rule = Array(&基本情况：([\s\S]+)(?=二、教育..：)&, &教育..：([\s\S]+)(?=三、工作..：)&, &工作经历：([\s\S]+)(?=四、优势..：)&, &推荐说明：([\s\S]+)(?=调研单位：)&)&&'创建正则表达式规则数组,用于提取各个大项文本
& & Do While FN && &&&&'当存在有效文件时循环提取
& && &&&With .documents.Open(ThisWorkbook.Path & &\& & FN)& &'打开文件
& && && && &Str = .Range.Text&&'读取文档文字内容
& && && && &.Close False&&'关闭文档(不保存)
& && &&&End With
& && &&&Arr(T, 14) = Dic(Left(FN, 1))&&'先写入推荐人信息
& && &&&With RegEx
& && && && &Arr(T, 1) = T - 1&&'写入序号
& && && && &For N = LBound(Rule) To UBound(Rule)&&'循环各个正则规则表达式项目
& && && && && & .Pattern = Rule(N)&&'将规则赋值给正则项目
& && && && && & Str2 = &&&&'初始化数据文本为空
& && && && && & If Rule(N) Like &基本*& Then&&'通过规则判断取得的结果区段,并进行最终信息提取
& && && && && && &&&If .test(Str) Then
& && && && && && && && &Str2 = .Execute(Str)(0).submatches(0)
& && && && && && && && &.Pattern = &\s*(\S?)：\s*&
& && && && && && && && &Str2 = .Replace(Str2, &$1 &)
& && && && && && && && &.Pattern = &[\r\n]+&
& && && && && && && && &Str2 = WorksheetFunction.Trim(.Replace(Str2, &&&&))
& && && && && && && && &Arrt = Split(Str2, & &)
& && && && && && && && &Arr(T, 2) = Arrt(1)
& && && && && && && && &Arr(T, 3) = Arrt(3)
& && && && && && && && &Arr(T, 4) = Arrt(11)
& && && && && && && && &Arr(T, 5) = Arrt(5)
& && && && && && &&&End If
& && && && && & ElseIf Rule(N) Like &教育*& Then
& && && && && && &&&If .test(Str) Then
& && && && && && && && &Str2 = .Execute(Str)(0).submatches(0)
& && && && && && && && &.Pattern = &[\r\n]+&
& && && && && && && && &Str2 = WorksheetFunction.Trim(.Replace(Str2, &&&&))
& && && && && && && && &Arrt = Split(Str2, & &)
& && && && && && && && &Arr(T, 6) = Arrt(1)
& && && && && && && && &Arr(T, 7) = Arrt(2)
& && && && && && && && &Arr(T, 8) = Arrt(3)
& && && && && && &&&End If
& && && && && & ElseIf Rule(N) Like &工作*& Then
& && && && && && &&&If .test(Str) Then
& && && && && && && && &Str2 = WorksheetFunction.Trim(.Execute(Str)(0).submatches(0))
& && && && && && && && &.Pattern = &\（[一二三四五六七**十]+\）(.+?)(?=[\r\n])&
& && && && && && && && &StrT = &&
& && && && && && && && &I = Year(Date)
& && && && && && && && &C = 0
& && && && && && && && &D = 0
& && && && && && && && &For Each mMatch In .Execute(Str2)
& && && && && && && && && & If C & 3 Then
& && && && && && && && && && &&&Arrt2 = Split(Replace(mMatch.submatches(0), & &, &&), &—&)
& && && && && && && && && && &&&If Arrt2(UBound(Arrt2)) Like &*至今*& Then
& && && && && && && && && && && && &D = Round((Year(Date) + Month(Date) / 12) - (Val(Arrt2(0)) + ((12 - Val(Split(Arrt2(0), &年&)(1))) / 12)), 1)
& && && && && && && && && && &&&Else
& && && && && && && && && && && && &D = Round((Val(Arrt2(UBound(Arrt2))) + Val(Split(Arrt2(UBound(Arrt2)), &年&)(1)) / 12) - (Val(Arrt2(0)) + ((12 - Val(Split(Arrt2(0), &年&)(1))) / 12)), 1)
& && && && && && && && && && &&&End If
& && && && && && && && && && &&&StrT = StrT & Split(mMatch.submatches(0), & &)(UBound(Split(mMatch.submatches(0), & &))) & &(& & D & &年)&
& && && && && && && && && && &&&'If C & 2 Then StrT = StrT & vbNewLine
& && && && && && && && && && &&&C = C + 1
& && && && && && && && && & End If
& && && && && && && && && & If Val(Split(mMatch.submatches(0), & &)(0)) & I Then I = Val(mMatch.submatches(0))
& && && && && && && && &Next mMatch
& && && && && && && && &Arr(T, 9) = Year(Date) - I
& && && && && && && && &Arr(T, 10) = StrT
& && && && && && &&&End If
& && && && && & ElseIf Rule(N) Like &推荐*& Then
& && && && && && &&&If .test(Str) Then
& && && && && && && && &Str2 = WorksheetFunction.Trim(.Execute(Str)(0).submatches(0))
& && && && && && && && &.Pattern = &建议贵.*司授予\s*\S+\s*(\S+)(?=\s*职务)&
& && && && && && && && &If .test(Str2) Then Arr(T, 11) = .Execute(Str2)(0).submatches(0)
& && && && && && && && &If Str2 Like &*待遇*面谈*& Then
& && && && && && && && && & Arr(T, 12) = &面谈&
& && && && && && && && &ElseIf Str2 Like &*期望*待遇不低于现有*& Then
& && && && && && && && && & .Pattern = &原公司\S*待遇是\s*((\d+\.)*\d+.*)(?=元)&
& && && && && && && && && & If .test(Str2) Then Arr(T, 12) = &&& & .Execute(Str2)(0).submatches(0)
& && && && && && && && &Else
& && && && && && && && && & .Pattern = &期望待遇是\s*((\d+\.)*\d+.*?)(?=\/)&
& && && && && && && && && & If .test(Str2) Then Arr(T, 12) = .Execute(Str2)(0).submatches(0)
& && && && && && && && &End If
& && && && && && &&&End If
& && && && && & End If
& && && && && & .Pattern = &(\d+)年(\d+)月(\d+)日\s*$&
& && && && && & If .test(Str) Then
& && && && && && &&&With .Execute(Str)(0)
& && && && && && && && &Arr(T, 13) = .submatches(0) & &.& & .submatches(1) & &.& & .submatches(2)
& && && && && && &&&End With
& && && && && & End If
& && && && &Next N
& && &&&End With
& && &&&T = T + 1&&'数据行下移一行
& && &&&FN = Dir&&'循环到下一文件
& & Loop
& & .AutomationSecurity = msoAutomationSecurityByUI& &'设置打开word文档时询问是否启用宏状态
& & .Quit&&'退出word进程
End With
With [a2].Resize(UBound(Arr), UBound(Arr, 2))
& & .Value = Arr&&'结果数组写入单元格区域中
& & With Intersect(Rows(2), .Cells)&&'设置标题行字体及颜色
& && &&&.Font.Color = vbRed
& && &&&.Font.Bold = True
& & End With
& & On Error Resume Next&&'设置容错
& & .SpecialCells(xlCellTypeBlanks) = &未知&&&'空白单元格写入&未知&字样(如果没有空白单元格则会因上一句的容错而继续执行,避免了程序中断)
End With
Columns.AutoFit&&'列宽自适应
Columns(&F:K&).ColumnWidth = 18&&'对可能会过宽的F:K列设置固定列宽
Cells.VerticalAlignment = xlCenter&&'文字剧中显示
Set RegEx = Nothing&&'清空创建的项目
Set Dic = Nothing
End Sub复制代码因程序提取的文件书写时存在一定的不规范性,为使程序能尽可能多的处理各种情况,需根据数据采集的实际情况不断丰富完善提取规则.
详见附件及素材源帖.
(198.4 KB, 下载次数: 288)
22:02 上传
点击文件名下载附件
如何利用vba批量从word文档中提取所需信息？（正则方式）
魅力值 +10
思路巧妙:)
学office，哪能不关注全网最大的Office类微博（新浪）
初级三, 积分 309, 距离下一级还需 191 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
謝謝提供學習下載中
学office，哪能不关注全网最大的Office类微博（新浪）
初级二, 积分 95, 距离下一级还需 155 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
我知道正则是很厉害的，我正在学习字典，希望能得到你的帮助
学office，哪能不关注全网最大的Office类微博（新浪）
初级二, 积分 215, 距离下一级还需 35 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
学office，哪能不关注全网最大的Office类微博（新浪）
新鲜人, 积分 6, 距离下一级还需 4 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
看到了好好学习一下
学office，哪能不关注全网最大的Office类微博（新浪）
初级三, 积分 327, 距离下一级还需 173 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
.EnableEvents = False 为黄色，提示“对象不支持属相或非法”
学office，哪能不关注全网最大的Office类微博（新浪）
初级二, 积分 80, 距离下一级还需 170 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
内容有些长，先下载学习
学office，哪能不关注全网最大的Office类微博（新浪）
初级一, 积分 47, 距离下一级还需 3 积分
积分学习力
魅力值 影响力
消费券 Ti币好友
在线时间 小时
最后登录月度优秀 次
下载学习,谢谢
学office，哪能不关注全网最大的Office类微博（新浪）
Excel技巧网的会员探讨问题仅代表其个人意见，与网站的立场无关。任何违反国家和地方相关法律法规的言论，本站有义务协助政府相关部门追究发言者的责任！
本站中非注明转载文章与案例的版权为作者与Excel技巧网共有。若非原文作者，本站之外任何单位或个人未经允许，不得将其用于商业用途。
若非原文作者，任何形式的非商业性转载必须获得Excel技巧网或作者允许，并注明作者和出处。
会员发表的帖子如涉及版权纠纷，须自行负责。详情请参考注册时的网站服务条款。
本站特聘法律顾问：沈学律师
Powered by君，已阅读到文档的结尾了呢~~
扫扫二维码，随身浏览文档
手机或平板扫扫即可继续访问
在学生成绩评定中利用VBA实现Excel函数功能
举报该文档为侵权文档。
举报该文档含有违规或不良信息。
反馈该文档无法正常浏览。
举报该文档为重复文档。
推荐理由：
将文档分享至：
分享完整地址
文档地址：
粘贴到BBS或博客
flash地址：
支持嵌入FLASH地址的网站使用
html代码：
&embed src='/DocinViewer-4.swf' width='100%' height='600' type=application/x-shockwave-flash ALLOWFULLSCREEN='true' ALLOWSCRIPTACCESS='always'&&/embed&
450px*300px480px*400px650px*490px
支持嵌入HTML代码的网站使用
您的内容已经提交成功
您所提交的内容需要审核后才能发布，请您等待！
3秒自动关闭窗口如何在Excel表中用A自动提取不及格学生的成绩 教程
全部答案（共2个回答）
生名单,并填写到“不及格名单”工作表中。(3)制作过程1)设置工作表如图1。①新建工作簿,选定“sheet1”工作表,设置为“数值型保留0位小数”,水平对齐方式为“居右”。②选定“sheet1”前三列,设置为“文本”,水平对齐方式为“居中”。③在第1行各单元格,分别输入“班级”、“学号”、“姓名”、“总分”及各学科名称。3、按Ctrl+A,选中所有单元格复制，右击选“选择性粘贴”为“数值”。4、然后自动筛选，把各科的自动筛选设置为“（空白）”，这样把全成绩为空白（即全科合格）的学生筛选出来，并选择这些筛选出来的学生姓名（全科全格的学生），按F5，点击“定位条件”，选择“可见单元格”，右击，选择“删除行”。再显示所有单元格，即为即为需要补考的情况。（此步骤可根据自己习惯灵活处理，也可...
基础设置建立一个工作簿,包含“成绩表”和“不及格名单”两个工作表。在“成绩表”中录入学生各科成绩。“不及格名单”用于存放提取的各科不及格的学生名单。2)提取不及格编写一段程序,从“成绩表”工作表中按行逐列提取不及格的各学相关信息生名单,并填写到“不及格名单”工作表中。(3)制作过程1)设置工作表如图1。①新建工作簿,选定“sheet1”工作表,设置为“数值型保留0位小数”,水平对齐方式为“居右”。②选定“sheet1”前三列,设置为“文本”,水平对齐方式为“居中”。③在第1行各单元格,分别输入“班级”、“学号”、“姓名”、“总分”及各学科名称。3、按Ctrl+A,选中所有单元格复制，右击选“选择性粘贴”为“数值”。4、然后自动筛选，把各科的自动筛选设置为“（空白）”，这样把全成绩为空白（即全科合格）的学生筛选出来，并选择这些筛选出来的学生姓名（全科全格的学生），按F5，点击“定位条件”，选择“可见单元格”，右击，选择“删除行”。再显示所有单元格，即为即为需要补考的情况。（此步骤可根据自己习惯灵活处理，也可用排序的方法删除空白单元格）
执行宏前用一个变量记下这个工作表的名。
sName=ActiveSheet.Name
宏结束前：
worksheets(sName).select
这个问题我觉得应该用change
Sub test()
Dim myQuery
With ActiveSheet
.Cells.Delete
...
亲，你好，最好的方法就是自己到网站去查看。
大家还关注
确定举报此问题
举报原因(必选)：
广告或垃圾信息
激进时政或意识形态话题
不雅词句或人身攻击
侵犯他人隐私
其它违法和不良信息
报告，这不是个问题
报告原因(必选)：
这不是个问题
这个问题分类似乎错了
这个不是我熟悉的地区查看: 22713|回复: 16
[已解决]两列人名顺序不一样想把第二列按第一列排序也就是对应
本帖最后由 q 于
12:39 编辑
田强田强付俊利付俊利王绍艳王绍艳陈裕娟陈裕娟于凤利于凤利张汉海徐国峰吴正平佘丽丽陈国庆敖长顺李兴华郭剑敏苏凤云王再学付晓青焦景坤郭静韦国兴余颖关晓鸣张艳洁郭军于红彬丁苏蒙
两列人名顺序不一样，想把第二列人名按第一列排序也就是对应& &以后总用，最好能有解说&&新手&&谢谢
第一列是我新做的&&第二列是上个月的表& &我想确认一下是不是一样的&&给人发钱怕落人
12:39 上传
点击文件名下载附件
9.52 KB, 下载次数: 133
第一列顺序不能变
实用价值很高。
JLxiangwei发布于
排序.gif (557.26 KB, 下载次数: 1038)
12:34 上传
我也等着学习，，好像在论坛里看过类似的题目，，忘记怎么做了，，温故而知新
听的不是很懂。
第二列的顺序跟第一列一样。
那不是全部都一样吗。
我要用第二列验证第一列的名对不对
把第一列的复制,再粘贴到第二列上不就对应了吗
那你在第三列 直接=a2=B2 不就可以了。
如果你要对比2列数据。可以用countif
上附件吧，楼主
&&&本楼为最佳答案&&&
排序.gif (557.26 KB, 下载次数: 1038)
12:34 上传
第一列是工资表顺序不能更改
我要和第二列对比&&看看是不是对的
问题解决但还是有点不美
有的还是对不上
希望能用函数的方法可能好点
我自己又用两个对比的方法检查能快点
Powered by达人明信片
个人说明：
这里也精彩}