一、需求说明
现有一批房产估值预评报告，文件格式为word的，内容格式规范统一，段落数量一致，现在需要提取黄色填充部分共6处文字内容到Excel表格中。
word文档内容格式：
Excel表格格式：
二、实现思路
利用ExcelVBA和Word进行交互操作，根据段落进行初步的内容定位，再利用正则表达式提取段落中的有效信息。
三、实现代码
Public Sub ExcelVba正则提取Word文档信息() '作者 DG-NextSeven 'QQ 84857038 '日期 2019年8月25日 '说明 Dim Wb As Workbook Dim Sht As Worksheet Dim FolderPath, FileName, FilePath, FilePaths Dim wdApp As Object Dim wdDoc As Object Set Wb = Application.ThisWorkbook Set Sht = Wb.Worksheets("模板") '清除标题以外的内容 Sht.UsedRange.Offset(1).ClearContents '调用函数，获取用户选择的文件路径 FilePaths = PickFilesArr("*.doc*") If FilePaths(1) = "NULL" Then Exit Sub '创建word应用程序对象 Set wdApp = CreateObject("word.application") i = 1 '循环所有word文档路径 For Each FilePath In FilePaths '打开word文档 Set wdDoc = wdApp.documents.Open(FilePath) '输出位置 行数递增 i = i + 1 '提取第二段中的姓名，分割剔除冒号 Sht.Cells(i, "A").Value = Split(wdDoc.Paragraphs(2).Range.Text, "：")(0) '利用正则表达式提取第三段中的房屋地址 pat = "位于(.*?)的" Sht.Cells(i, "B").Value = RegGet(wdDoc.Paragraphs(3).Range.Text, pat) '利用正则表达式提取第三段中的价值时点 pat = "价值时点为.*?(\d+月\d+日)" Sht.Cells(i, "C").Value = RegGet(wdDoc.Paragraphs(3).Range.Text, pat) '利用正则表达式提取第三段中的建筑面积 pat = "建筑面积为([\d\.]*?)平方米" Sht.Cells(i, "D").Value = RegGet(wdDoc.Paragraphs(3).Range.Text, pat) '利用正则表达式提取第四段中的抵押价值 pat = "抵押价值为([\d\.]*?)元" Sht.Cells(i, "E").Value = RegGet(wdDoc.Paragraphs(4).Range.Text, pat) '利用正则表达式提取第四段中的大写抵押价值 pat = "人民币大写：(.*?)。" Sht.Cells(i, "F").Value = RegGet(wdDoc.Paragraphs(4).Range.Text, pat) '关闭word文档 wdDoc.Close False Next FilePath '退出word应用程序 wdApp.Quit '释放对象变量 Set wdApp = Nothing Set wdDoc = Nothing Set Wb = Nothing Set Sht = Nothing MsgBox "提取完成"End Sub'自定义函数：弹窗选定一个或者多个文件，返回数组Function PickFilesArr(Optional FileTypeFilter As String = "", Optional FileNameContain As String = "*", Optional FileNameNotContain As String = "") As String() Dim FilePath As String Dim Arr() As String ReDim Arr(1 To 1) Dim FileCount As Long Dim i As Long FileCount = 0 With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .InitialFileName = Application.ActiveWorkbook.Path .Title = "请选择你需要的文件" .Filters.Clear If Len(FileTypeFilter) > 0 Then .Filters.Add "您需要的文件类型", FileTypeFilter End If If .Show = -1 Then Arr(1) = "NULL" For i = 1 To .SelectedItems.Count If .SelectedItems(i) Like FileNameContain Then If Len(FileNameNotContain) = 0 Then FileCount = FileCount + 1 ReDim Preserve Arr(1 To FileCount) Arr(FileCount) = .SelectedItems(i) Debug.Print Arr(FileCount) Else If Not .SelectedItems(i) Like FileNameNotContain Then FileCount = FileCount + 1 ReDim Preserve Arr(1 To FileCount) Arr(FileCount) = .SelectedItems(i) End If End If End If Next i PickFilesArr = Arr Else 'MsgBox "Pick no file！" Arr(1) = "NULL" PickFilesArr = Arr Exit Function End If End WithEnd Function'自定义函数：利用正则表达式，根据匹配模式提取字符串中首次出现的符合子字符串Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String Dim Regex As Object Dim Mh As Object Set Regex = CreateObject("VBScript.RegExp") With Regex .Global = True .Pattern = Pattern End With If Regex.test(OrgText) Then Set Mh = Regex.Execute(OrgText) RegGet = Mh.Item(0).submatches(0) Else RegGet = "" End If Set Regex = NothingEnd Function四、要点解释
大部分知识点，在之前的文章已经使用过，正则表达式是很好用的一个工具，略懂皮毛就可以解决日常工作中的字符串处理问题。这个需要大家自行去搜索、阅读、练习。这里主要了利用了前后的文字进行定位，如
pat = "位于(.*?)的"
就是提取文字“位于”和文字“的”之间的内容，点号.代表任意内容，星号*为任意且尽可能多数量，问号？就是抑制星号*的作用，让它尽可能少匹配文字。
如果不在？问号，则pat会匹配“位于”后面直到本段落最后一个“的”字前面的内容，也就是“估值目的”中的“的”前面的内容，加上问号才能准确得到我们想要的内容。
五、写在最后
停更了差不多两个月，无他，诸事不顺，做事没了心气。每一件不顺的事情都如一条巨大的缰绳，困住了手脚，使我动弹不得。
近日正好有个案例，更新一下，露个脸。
本文章为转载内容，我们尊重原作者对文章享有的著作权。如有内容错误或侵权问题，欢迎原作者联系我们进行内容更正或删除文章。
