如何批量提取word指定内容到excel中啊

零公里图

如何批量提取word指定内容到excel中啊

jiangxiaoyun

用到的是tables对象及其cell对象相关只是,都是提取word表格数据.

约定的童话

Mark学习一下

Moneky

用我的doc2xls吧

182197315

Sub 汇总()
    [B2:I100000].ClearContents
    Dim wordapp, wordD
    Dim cPath$, cFile$, str$, i%, arr(1 To 10000, 1 To 10)
    cPath = ThisWorkbook.Path & "\采购供货单1个\"
    cFile = Dir(cPath & "*.doc")
    Set wordapp = CreateObject("Word.Application")
    Do While cFile <> ""
        Set wordD = wordapp.Documents.Open(cPath & cFile)
        i = i + 1
        With wordD.Tables(1)
            arr(i, 1) = i
            arr(i, 2) = Replace(Replace(.Cell(1, 2).Range.Text, Chr(7), ""), Chr(13), "")
            arr(i, 3) = Replace(Replace(.Cell(2, 2).Range.Text, Chr(7), ""), Chr(13), "")
        End With
        With wordD.Tables(2)
            arr(i, 4) = Replace(Replace(.Cell(2, 2).Range.Text, Chr(7), ""), Chr(13), "")
            arr(i, 5) = Replace(Replace(.Cell(2, 3).Range.Text, Chr(7), ""), Chr(13), "")
            arr(i, 6) = Replace(Replace(.Cell(2, 4).Range.Text, Chr(7), ""), Chr(13), "")
            arr(i, 7) = Replace(Replace(.Cell(2, 6).Range.Text, Chr(7), ""), Chr(13), "")
            arr(i, 8) = Replace(Replace(.Cell(2, 8).Range.Text, Chr(7), ""), Chr(13), "")
            arr(i, 9) = Replace(Replace(.Cell(2, 10).Range.Text, Chr(7), ""), Chr(13), "")
            arr(i, 10) = Replace(Replace(.Cell(2, 11).Range.Text, Chr(7), ""), Chr(13), "")
        End With
        wordD.Close
        cFile = Dir
    Loop
    Set wordD = Nothing
    wordapp.Quit
    Range("A2").Resize(UBound(arr), 10).Value = arr
End Sub

182197315

可以实现了，楼主试试。

风掠无痕

提取不了？？？？

零公里图

182197315 发表于 2019-11-25 12:18
可以实现了，楼主试试。

可以，但是如果随时采购订单1个这个文件中增加word文件，如何实现呢？

零公里图

182197315 发表于 2019-11-25 12:18
可以实现了，楼主试试。

谢谢，可以实现了

lizhipei78

https://club.excelhome.net/thread-1679604-1-1.html
通用，不求人