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

庄生小虫

lsdongjh 发表于 2018-5-9 16:24
你把这个去掉这成

老师，还是有问题。新装了2013版（破解版）OFFICE，一样还是丢失 16.0 object lib...

lsdongjh

去掉这个就行，

182197315

Sub 提取()
Dim i%, k%, arr(1 To 10000, 1 To 7), myPath$, myFile$, s1$, s2$, wdapp
Set wdapp = CreateObject("Word.Application")
Dim wdD As Word.Document
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.doc?")
Do While myFile <> ""
    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 i = 2 To .Rows.Count
            If Len(.Cell(i, 4).Range.Text) = 2 Then
                k = k + 1
                arr(k, 1) = k
                arr(k, 3) = s1
                arr(k, 4) = s2
                arr(k, 5) = Replace(.Cell(i, 2).Range.Text, Chr(7), "")
            End If
        Next
    End With
    wdD.Close
    myFile = Dir
Loop
wdapp.Quit
Set wdD = Nothing
Range("A3").CurrentRegion.Offset(2).ClearContents
Range("A3").Resize(UBound(arr), 7) = arr
End Sub

jjmysjg

无法运行，麻烦各位老师看看

庄生小虫

182197315 发表于 2018-5-9 21:24
Sub 提取()
Dim i%, k%, arr(1 To 10000, 1 To 7), myPath$, myFile$, s1$, s2$, wdapp
Set wdapp = Crea ...

老师，提示问题见截图：

182197315

Sub 提取()
Dim i%, k%, arr(1 To 10000, 1 To 7), myPath$, myFile$, s1$, s2$, r%, c%, wdApp, d
Set d = CreateObject("scripting.dictionary")
Set wdApp = CreateObject("Word.Application")
Dim wdD As Word.Document
myPath = ThisWorkbook.Path & "\"
myFile = Dir(myPath & "*.doc?")
Do While myFile <> ""
    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
                k = k + 1
                arr(k, 1) = k
                arr(k, 3) = s1
                arr(k, 4) = s2
                arr(k, 5) = Replace(.Cell(i, d(i) - 5).Range.Text, Chr(7), "")
            End If
        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

这次应该没问题了，含有合并单元格的行也能正常提取

Moneky

庄生小虫 发表于 2018-5-10 10:27
老师，提示问题见截图：

去掉丢失的word 16.0的引用，然后添加你电脑上对应版本的word的引用。类似于Microwsoft Word **.0 Library

182197315

庄生小虫 发表于 2018-5-10 10:27
老师，提示问题见截图：

搞定了没有

庄生小虫

182197315 发表于 2018-5-11 09:48
搞定了没有

谢老师关心。都不好意思再问了。您的很好，就是能不能再帮我完善一下，见附图