关于多个Word文件中表格内容批量导入Excel的问题

xykoo

如何将WORD里面的各字段提取到新建EXCEL里？由于每个人都是一张表，人工操作费时费力。请求高手们帮助，谢谢。

xykoo

求助

xykoo

求助！！！！！！！！

3190496160

Sub 从word到excl()
Application.ScreenUpdating = False
    Dim i%, myPath$, wdApp, wdD
    Dim arr()
    Dim oFso
    Set oFso = CreateObject("Scripting.FileSystemObject")
    Dim d As Object
    Set d = CreateObject("scripting.dictionary")
    myPath = ThisWorkbook.Path & "\"
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = True
    ReDim arr(1 To 500, 1 To 19)
    f = Dir(myPath & "*.doc*")
    Do While f <> ""
        Set wdD = wdApp.Documents.Open(myPath & f)
        n = n + 1
        With wdD.Tables(1)
            arr(n, 1) = n
            arr(n, 2) = .cell(1, 2).Range.Text
            arr(n, 3) = .cell(1, 4).Range.Text
            arr(n, 4) = .cell(1, 6).Range.Text
            arr(n, 5) = .cell(1, 8).Range.Text
            arr(n, 6) = .cell(2, 2).Range.Text
            arr(n, 7) = .cell(3, 3).Range.Text
            arr(n, 8) = .cell(3, 5).Range.Text
            arr(n, 9) = .cell(3, 7).Range.Text
            arr(n, 10) = .cell(4, 3).Range.Text
            arr(n, 11) = .cell(5, 3).Range.Text
            arr(n, 12) = .cell(4, 5).Range.Text
            arr(n, 13) = .cell(5, 5).Range.Text
            arr(n, 14) = .cell(6, 3).Range.Text
            arr(n, 15) = .cell(7, 3).Range.Text
            arr(n, 16) = .cell(6, 5).Range.Text
            arr(n, 17) = .cell(7, 5).Range.Text
            arr(n, 18) = .cell(8, 3).Range.Text
            arr(n, 19) = .cell(9, 3).Range.Text
        End With
        wdD.Close True
    f = Dir
    Loop
    wdApp.Quit
    With Sheet1
        .[a1].CurrentRegion.Offset(1) = Empty
        .[a2].Resize(n, 19) = arr
    End With
    Set wdD = Nothing
    Set wdApp = Nothing
Application.ScreenUpdating = False
    MsgBox "ok!"
End Sub

3190496160

仅供参考
请求高手写个宏帮助下.rar (47.19 KB, 下载次数: 33)

2021-8-12 11:03 上传

点击文件名下载附件

xykoo

3190496160 发表于 2021-8-12 11:03
仅供参考

非常感谢！！！！！！！！！！！！！