急！！！批量提取word指定内容到Excel

LOYOTO

opiona 发表于 2022-8-23 17:46

求高手解决难题，https://club.excelhome.net/forum ... ;page=1#pid11059230

陈浩679070

可以一试试；可以一试试；可以一试试；可以一试试；可以一试试；

陈浩679070

Sub Tmac()  '正则提取
Dim wordApp As Object  '定义Word对象
Dim d As Object, str1$, p
Set wordApp = CreateObject("Word.Application") '--绑定Word对象
wordApp.Visible = True  '设置Word对象可见
Set d = wordApp.Documents.Open(ThisWorkbook.Path & "\新和平小区1类（终审版）(1).docx")  '打开Word文件
  
    '创建正则提取数据
  Dim rege As Object, sItem As Object, dItem As Object, i%, j%, jsNum As Long
  Set rege = CreateObject("vbscript.regexp")
jsNum = 2 '//从第2行开始放数据
Range("a1").CurrentRegion.Offset(1, 0).ClearContents
For Each p In d.Paragraphs  '//循环每个段落

'----------------------------------------------------------------------------
    With rege
      .Global = True
      .Pattern = "(NO.+\(.+\))|(您（拥有/居住）的(.*)小区(.+)[栋,期]((.+单元)|(.+楼))(.+)号房屋)|(.+(欠费(.+)元.+滞纳金(.+)元.+合计欠费(.+)元))"
        If Len(p.Range.Text) > 1 Then
        Set sItem = .Execute(p.Range.Text)
          'MsgBox p.Range.Text
            '----------------------------------------------------------------------------
            If sItem.Count > 0 Then    '//判断是否匹配到结果
              If sItem.Item(0).Value Like "NO*" Then
                  Cells(jsNum, 1) = sItem.Item(0).Value
                  
              ElseIf sItem.Item(0).Value Like "您（拥有/居住）的*" Then
                      Cells(jsNum, 2) = Trim(sItem.Item(0).submatches(2))
                      Cells(jsNum, 3) = Trim(sItem.Item(0).submatches(3))
                      Cells(jsNum, 4) = Replace(Trim(sItem.Item(0).submatches(4)), Chr(32), "") '//替换空格
                      Cells(jsNum, 5) = Trim(sItem.Item(0).submatches(7))
              ElseIf sItem.Item(0).Value Like "*欠费*" Then
                For i = 0 To 2
                    Cells(jsNum, i + 6) = Trim(sItem.Item(0).submatches(i + 10))
                Next
                jsNum = jsNum + 1
               End If
            End If
           '----------------------------------------------------------------------------
        End If
    End With
'----------------------------------------------------------------------------
Next  '\\段落循环
MsgBox "您好，数据已处理完毕@"
Set rege = Nothing
d.Close
wordApp.Visible = False
Set d = Nothing
End Sub

cai2532

这个word提取实例收藏备用。

lizhipei78

https://club.excelhome.net/thread-1679604-1-1.html