提取word固定表格中固定单元格的内容

duhj999

表格样式完全一样，批量提取标黄部分的内容汇总到excel中。

3190496160

Sub 提取数据()
    Application.ScreenUpdating = False
    Dim FilePath As String
    Dim n As Integer
    Dim arr()
    FilePath = ThisWorkbook.Path & "\" '"E:\文档\Word Demo\图片打印\9连环18件套" 'ChooseFolder
    Dim WordApp As Object
    Set WordApp = CreateObject("Word.Application")   '新建Word对象
    WordApp.Visible = False
    f = Dir(FilePath & "*.doc*")
    ReDim arr(1 To 10000, 1 To 5)
    Do While f <> ""
        n = n + 1
        arr(n, 1) = n
        Set WordD = WordApp.Documents.Open(FilePath & f)
        With WordD.tables(1)
            arr(n, 2) = Replace(.Cell(1, 2).Range.Text, Chr(13) & Chr(7), "") '建设单位
            arr(n, 3) = Replace(.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")  '工程名称
            arr(n, 4) = Replace(.Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")  '建筑面积
            xh = InStr(.Cell(4, 1).Range.Text, "实施单位在") + 5
            arr(n, 5) = Mid(Replace(.Cell(4, 1).Range.Text, Chr(13) & Chr(7), ""), xh, 22) '工程造价
        End With
    f = Dir
    Loop
    Set WordD = Nothing
    WordApp.Quit
    [a1].CurrentRegion.Offset(1) = Empty
    Range("a2").Resize(n, 5) = arr
    Application.ScreenUpdating = True
    MsgBox "完成"
End Sub

3190496160

模板.rar (47.76 KB, 下载次数: 5)

2022-12-7 11:12 上传

点击文件名下载附件

梧叶沙沙

我的插件可以完美提取，Word魔方。

梧叶沙沙

Word魔方下载地址
https://wwi.lanzoup.com/b0127njmf提取码:1dhp

duhj999

3190496160 发表于 2022-12-7 11:15

完美解决，非常感谢！！