从多张word表中提取数据到表格中

xxpxxp

我下面这个vba可以运行，但运行一段时间后就自动停止，提取的数据也不见了。另外application.screenupdating=false,也关闭不了屏幕更新，为什么，请高手指导。
Sub extract()
    Dim nfile As String
    Dim nextrow As Integer
    Dim mypath As String

    Application.ScreenUpdating = False
    nextrow = 2

    mypath = ThisDocument.Path & "\"
    nfile = Dir(mypath)
    Documents.Open FileName:=mypath & nfile
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 1).Range = Documents(nfile).Tables(1).Cell(1, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 2).Range = Documents(nfile).Tables(1).Cell(1, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 3).Range = Documents(nfile).Tables(1).Cell(1, 6).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 4).Range = Documents(nfile).Tables(1).Cell(2, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 5).Range = Documents(nfile).Tables(1).Cell(2, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 6).Range = Documents(nfile).Tables(1).Cell(2, 6).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 7).Range = Documents(nfile).Tables(1).Cell(3, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 8).Range = Documents(nfile).Tables(1).Cell(3, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 9).Range = Documents(nfile).Tables(1).Cell(3, 6).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 10).Range = Documents(nfile).Tables(1).Cell(4, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 11).Range = Documents(nfile).Tables(1).Cell(4, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 12).Range = Documents(nfile).Tables(1).Cell(5, 3).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 13).Range = Documents(nfile).Tables(1).Cell(5, 5).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 14).Range = Documents(nfile).Tables(1).Cell(6, 3).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 15).Range = Documents(nfile).Tables(1).Cell(6, 5).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 16).Range = Documents(nfile).Tables(1).Cell(7, 2).Range

           Documents(nfile).Close False

            Do While nfile <> "" And nfile <> "汇总表.docm.docx"
                nextrow = nextrow + 1
                    nfile = Dir
                        Documents.Open FileName:=mypath & nfile
                                Documents("汇总表.docm").Tables(1).Cell(nextrow, 1).Range = Documents(nfile).Tables(1).Cell(1, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 2).Range = Documents(nfile).Tables(1).Cell(1, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 3).Range = Documents(nfile).Tables(1).Cell(1, 6).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 4).Range = Documents(nfile).Tables(1).Cell(2, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 5).Range = Documents(nfile).Tables(1).Cell(2, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 6).Range = Documents(nfile).Tables(1).Cell(2, 6).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 7).Range = Documents(nfile).Tables(1).Cell(3, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 8).Range = Documents(nfile).Tables(1).Cell(3, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 9).Range = Documents(nfile).Tables(1).Cell(3, 6).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 10).Range = Documents(nfile).Tables(1).Cell(4, 2).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 11).Range = Documents(nfile).Tables(1).Cell(4, 4).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 12).Range = Documents(nfile).Tables(1).Cell(5, 3).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 13).Range = Documents(nfile).Tables(1).Cell(5, 5).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 14).Range = Documents(nfile).Tables(1).Cell(6, 3).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 15).Range = Documents(nfile).Tables(1).Cell(6, 5).Range
        Documents("汇总表.docm").Tables(1).Cell(nextrow, 16).Range = Documents(nfile).Tables(1).Cell(7, 2).Range
            Documents(nfile).Close False
            Loop
        Application.ScreenUpdating = True
End Sub

ming0018

来个附件吧，不然写不出来。

xxpxxp

一张汇总表附带一张word样表

ming0018

xxpxxp 发表于 2018-7-24 09:08
一张汇总表附带一张word样表

可否用excel来收集汇总？

ming0018

用excel做的汇总效果图。

xxpxxp

可以的，但我不知道上边的程序错在哪儿了

xxpxxp

为什么提取的数据后边都有个黑点啊

ming0018

xxpxxp 发表于 2018-7-24 11:17
为什么提取的数据后边都有个黑点啊

黑点是word表格中的换行符，替换掉就行了。
没空看你的代码，具体原因不清楚。

洋洋的爸爸

厉害，学习下