EXCEL自动提取该WORD中的某一部分内部填入相应的EXCEL单元格

fnre

各位大神请帮帮忙，在某一文件夹内每新建一个WORD文档时，让EXCEL自动提取该文档中的某一部分内容填入相应的EXCEL单元格。非常感谢！


补充内容 (2020-1-9 15:06):
自己疏忽，压缩包里少了台账工作簿。因没找到编辑在哪里，已在5楼重新上传，请哪位大师帮帮忙，谢谢了！

fnre

有大师在吗？

蓝桥玄霜

没有看到有台账工作簿。

182197315

楼主少传了一个文件吧

fnre

不好意思，上传的少了台账工作簿，重新上传。请大师帮帮忙，谢谢！

fnre

182197315 发表于 2020-1-7 17:09
楼主少传了一个文件吧

是少传了一个文件，谢谢！

fnre

蓝桥玄霜 发表于 2020-1-7 12:17
没有看到有台账工作簿。

不小心少传了台账工作簿，谢谢提醒，请百忙中抽空帮帮我，非常谢谢！！

EXCELLMY

fnre 发表于 2020-1-9 15:03
不小心少传了台账工作簿，谢谢提醒，请百忙中抽空帮帮我，非常谢谢！！

fnre.rar (58.4 KB, 下载次数: 19)

2020-1-9 15:19 上传

点击文件名下载附件

MerlynSong

EXCELLMY 发表于 2020-1-9 15:19

这个并没有填充上去？

魂断蓝桥

Sub a()
'必须提前引用word对象
    Dim WrdDoc, MyPath, MyFile, i%, m%, t%, ran, s$
    Dim app As New Word.Application
    i = 2
    MyPath = ThisWorkbook.Path
    MyFile = Dir(MyPath & "\入库单\*.docx")
    Application.ScreenUpdating = False
    Do While MyFile <> ""
        Set WrdDoc = app.Documents.Open(MyPath & "\入库单\" & MyFile)
        app.Visible = True
        app.Selection.HomeKey unit:=wdStory
        Set ran = WrdDoc.Range
        With ran.Find
            .ClearFormatting
            .Text = "1、"
            .Wrap = 1
            If .Execute Then
                m = ran.Start
                i = i + 1
                s = WrdDoc.Range(m, WrdDoc.Range.End)
                Cells(i, 4) = Left(s, InStr(s, "（以下空白）") - 1)
            End If
        End With
        WrdDoc.Close
        MyFile = Dir
    Loop
    app.Quit
    Set app = Nothing
     Application.ScreenUpdating = True
End Sub