请老师帮忙提取word内容到excel

qdchyq

老师，有多个word文件，vba提取指定内容到excel，见excel，感谢

3190496160

这类问题的帖子，论坛一搜一大把

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, i&, r&, wdApp As Object, strFileName$, strPath$, regEx As Object
         
    Application.ScreenUpdating = False
     
    ReDim ar(1 To 10 ^ 3, 1)
    ar(1, 0) = "单位": ar(1, 1) = "资料"
    r = 1
     
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "\d+年资料"
     
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = Dir(strPath & "*.doc*")
    Do Until strFileName = ""
        With wdApp.documents.Open(strPath & strFileName)
            r = r + 1
            ar(r, 0) = .Range(.Paragraphs(2).Range.Start, .Paragraphs(2).Range.End - 2)
            If regEx.test(.Content.Text) Then
                ar(r, 1) = regEx.Execute(.Content.Text)(0).Value
            End If
            
            .Close False
        End With
        strFileName = Dir
    Loop
        
    Cells.Clear
    [A1].Resize(r, 2) = ar
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Set regEx = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

qdchyq

gwjkkkkk 发表于 2024-6-10 15:52
请参考附件。。。

谢谢老师，非常感谢