将多个word中的评分项汇总到excel中

duoduolianxi

将多个word中的评分项汇总到excel中，见附件。请求帮助，有偿，+v信186 4266 6862。我不用qq。

蓝桥玄霜

提取文档数据的代码：
多文档可自行扩展。

duoduolianxi

蓝桥玄霜 发表于 2019-12-17 13:02
提取文档数据的代码：
多文档可自行扩展。

感谢代码，我研究一下。

魂断蓝桥

Sub 提取word()
    Dim WrdDoc, MyPath, MyFile, i%, m%, arr(1 To 99, 1 To 20), j%
    Dim app
    Set app = CreateObject("Word.Application")
    MyPath = ThisWorkbook.Path
    MyFile = Dir(MyPath & "\*.docx")
    [a2:v999] = ""
    Do While MyFile <> ""
        'app.Visible = True
        Set WrdDoc = app.Documents.Open(MyPath & "\" & MyFile)
        m = m + 1
        arr(m, 1) = m
        With WrdDoc
            arr(m, 2) = .Tables(1).Cell(1, 6).Range.Text
            arr(m, 3) = .Tables(2).Cell(1, 2).Range.Text
            arr(m, 4) = .Tables(1).Cell(1, 2).Range.Text
            arr(m, 5) = Replace(.Tables(2).Cell(2, 2).Range.Text, ".", "-")
            arr(m, 6) = Replace(.Tables(2).Cell(2, 4).Range.Text, ".", "-")
            arr(m, 7) = .Tables(1).Cell(3, 6).Range.Text
            For i = 3 To 7
                arr(m, i + 6) = .Tables(2).Cell(i, 4).Range.Text
            Next
            For i = 8 To 12
                arr(m, i + 8) = .Tables(2).Cell(i, 4).Range.Text
            Next
        End With
        WrdDoc.Close
        MyFile = Dir
    Loop
    app.Quit
    For i = 1 To m
        For j = 1 To 20
            arr(i, j) = Application.WorksheetFunction.Clean(arr(i, j))
        Next
    Next
    [a2].Resize(m, 20) = arr
    Range("e2:f999").NumberFormat = "yyyy-mm-dd"
    Set app = Nothing
End Sub

duoduolianxi

魂断蓝桥 发表于 2019-12-18 09:58
Sub 提取word()
    Dim WrdDoc, MyPath, MyFile, i%, m%, arr(1 To 99, 1 To 20), j%
    Dim app

太厉害了，简直太棒了，高手，向您学习~