运用EXCEL VBA批量提取 word中 第三个表的数据

182197315

不清楚你的具体要求，先琢磨着写了一个


Sub 提取()
Dim i%, k%, arr(1 To 10000, 1 To 7), myPath$, myFile$, s1$, s2$, r%, c%, wdApp, d, temp
Set d = CreateObject("scripting.dictionary")
Set wdApp = CreateObject("Word.Application")
Dim wdD As Word.Document
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.doc?")
On Error Resume Next
Do While myFile <> ""
    k = k + 1
    arr(k, 5) = ""
    Set wdD = wdApp.Documents.Open(myPath & myFile)
    With wdD.Tables(1)
        s1 = Replace(.Cell(1, 2).Range.Text, Chr(7), "")
        s2 = Replace(.Cell(2, 2).Range.Text, Chr(7), "")
    End With
    With wdD.Tables(3)
        For Each mycell In .Range.Cells
            r = mycell.RowIndex
            c = mycell.ColumnIndex
            If c > d(r) Then d(r) = c
        Next
        For i = 2 To .Rows.Count
            If Len(.Cell(i, d(i) - 3).Range.Text) = 2 Then
                temp = Replace(.Cell(i, 2).Range.Text, Chr(7), "")
                If Err.Number = 0 Then
                    arr(k, 1) = k
                    arr(k, 2) = Split(myFile, ".")(0)
                    arr(k, 3) = s1
                    arr(k, 4) = s2
                    If Len(arr(k, 5)) > 0 Then arr(k, 5) = arr(k, 5) & "，"
                    arr(k, 5) = arr(k, 5) & temp
                End If
            End If
            Err.Clear
        Next
    End With
    wdD.Close
    myFile = Dir
Loop
wdApp.Quit
Set wdD = Nothing
Set wdApp = Nothing
Set d = Nothing
Range("A3").CurrentRegion.Offset(2).ClearContents
Range("A3").Resize(UBound(arr), 7) = arr
End Sub

庄生小虫

182197315 发表于 2018-5-11 18:36
不清楚你的具体要求，先琢磨着写了一个

可用，谢谢老师，忘记回复您了

庄生小虫

182197315 发表于 2018-5-11 18:36
不清楚你的具体要求，先琢磨着写了一个

老师，您好！首先特别感谢您之前的热情帮助。在使用一段时间之后，延迟统计有两个问题，自己尝试解决不了，请您再次援手（附件传了两个问题的例子）：1. 问题1说明：对于 word表3全部填满的（即非延迟的），统计表会空栏，未将统计记录依次罗列。
2.问题2说明： 当 出现表3中第一栏为合并单元格的文件时（其他栏的合并没有影响，可以继续统计），统计不到其后的文件。如：CTT180592601 冬菇 表三第一栏为合并单元格，会统计不到CTT180592652 黑木耳（分装）的数据。


非常感谢！

jiminyanyan

做个记号。。。。

庄生小虫

jiminyanyan 发表于 2018-8-21 21:05
做个记号。。。。

谢谢关注，谢谢！

182197315

没看懂，如有需要，可与我联系