把WORD指定内容提取到Excle表格

ruiqian

请大师们帮忙：把WORD指定内容提取到Excle表格

zpy2

https://club.excelhome.net/forum.php?mod=viewthread&tid=1661892&mobile

ruiqian

zpy2 发表于 2023-5-28 07:19
https://club.excelhome.net/forum.php?mod=viewthread&tid=1661892&mobile

是word转Excle哦

smiletwo

ruiqian

smiletwo 发表于 2023-5-28 16:01

能否上传附件？

ruiqian

smiletwo 发表于 2023-5-28 16:01

可否上传附件

smiletwo

            

smiletwo

Sub ss()
    Dim i, j, arr, txt, MyDoc As Object, reg As Object, mh
    Set MyDoc = GetObject(ThisWorkbook.Path & "\原稿.docx")
    txt = MyDoc.Content.Text
    MyDoc.Close
    Set MyDoc = Nothing
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True
    reg.Pattern = "([0-9]+．[\w\W]+?)(A．[\w\W]+?)(B．[\w\W]+?)(C．[\w\W]+?)(D．[\w\W]+?)【分析】([\w\W]+?)故选[：]?([A-Z]+)"
    If reg.test(txt) Then
        Set mh = reg.Execute(txt)
        ReDim arr(1 To mh.Count, 1 To 7)
        For i = 1 To UBound(arr)
            For j = 1 To UBound(arr, 2)
                arr(i, j) = mh(i - 1).submatches(j - 1)
            Next j
        Next i
    End If
    Set reg = Nothing
    Sheet1.Range("B2").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub

smiletwo

                 重新写了

ruiqian

smiletwo 发表于 2023-5-30 11:35
重新写了

老师，太感谢您了。试了模版，成功！不过，解析与答案位置有些出入，请问怎么修改？