加Msgbox句后才运行正确

henterwu

此宏目的是2将目录中Word文件的表格内容导入到Excel中。

调试过程中发现，只有在某处加一句MsgBox才能得到正确结果。请各位帮助看一下哪里有问题？谢谢！

Sub 提取word表格()
On Error Resume Next
Range("A2:AN1000").ClearContents
Application.ScreenUpdating = False
Dim data(1 To 600, 1 To 40) As String
i = 0
mypath = ThisWorkbook.Path & "\"
myname = Dir(mypath & "*.docx")
Do While myname <> ""
Set mydoc = GetObject(mypath & myname)
    With mydoc
        With .tables(1)
        d = 1
            For ro = 1 To 6
            data(1 + i * 5, d) = Left(.cell(ro, 2).Range.Text, Len(.cell(ro, 2).Range.Text) - 1)
            data(1 + i * 5, d + 1) = Left(.cell(ro, 4).Range.Text, Len(.cell(ro, 4).Range.Text) - 1)
            d = d + 2
            Next
        End With
        With .tables(2)
        For ro2 = 0 To 4
            data(1 + i * 5 + ro2, 12) = Left(.cell(ro2 + 2, 1).Range.Text, Len(.cell(ro2 + 2, 1).Range.Text) - 1)
            data(1 + i * 5 + ro2, 13) = Left(.cell(ro2 + 2, 2).Range.Text, Len(.cell(ro2 + 2, 2).Range.Text) - 1)
            data(1 + i * 5 + ro2, 14) = Left(.cell(ro2 + 2, 3).Range.Text, Len(.cell(ro2 + 2, 3).Range.Text) - 1)
            data(1 + i * 5 + ro2, 15) = Left(.cell(ro2 + 2, 4).Range.Text, Len(.cell(ro2 + 2, 4).Range.Text) - 1)
        Next
i = i + 1
        End With
.Close False

''''''''加了MsgBox，才运行正常。否则每次运行结果都不同且不正确。实在不理解！请各位指点。谢谢！
MsgBox ""
'''''''
End With
myname = Dir
Loop
[A2:AN601] = data
Set mydoc = Nothing
Application.ScreenUpdating = True
End Sub

鄂龙蒙

改这句：
if ro<6 then data(1 + i * 5, d + 1) = Left(.cell(ro, 4).Range.Text, Len(.cell(ro, 4).Range.Text) - 1)

鄂龙蒙

第1个表的第6行是合并单元格

henterwu

十分感谢！

henterwu

发现问题依旧。如果不运行MsgBox，结果还是错误。哪位老师能解释修改一下。真的有点不可思议。谢谢！

taller

不要随意使用On Error Resume Next，才能看到是哪句出错

按照2楼修订代码，测试没有任何问题

henterwu

好的。谢谢taller

henterwu

不过还是不理解为什么加了msgbox就对了？否则就缺了不等两个文件的内容？

henterwu

对以上现象表示深度不解。之前也用F8逐条调试过。难道是我的office出问题了？

henterwu

因为是缺了其中两个文件的所有内容，并不像因为合并单元格而缺了相关内容。而且，每个文件的格式都是相同的。
下图是根据修改后的代码的运行结果截图。看来是另有元凶。