Word文档表格提取到Excel 再次求助论坛老师出手

1013182120

    上个帖子沉了，，这是一位论坛老师的代码我拿来用了，现在出现了点问题，特再次求助老师们，求助1：电脑都是win10系统，vba代码在word2013版里面运行，能提取到excel成功，在另一台电脑word2021版里面提取到excel空白，求助老师解决下，求助2：我想把不再表格里面抬头的那个“立〔2024〕第xx号"也提取出来，求助老师改下代码以便实现以上功能。再次谢谢各位。

gwjkkkkk

Option Explicit
Sub test() '
    Dim wdApp As Object, Items As FileDialogSelectedItems, vItem, strPath$
    Dim ar, br, i&, j&, strRngText$
    strPath = ThisWorkbook.Path & "\测试文件\"
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "Word文档(doc?)", "*.doc?"
        End With
        .AllowMultiSelect = True
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
   
    Application.ScreenUpdating = False
    br = [{2,3;4,4;6,5;8,6;12,7;14,8;16,9;21,10;23,11;25,12;27,13;29,14;31,15;34,16;36,17;38,18}]
    ReDim ar(1 To Items.Count, 1 To 18)
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
   
    For i = 1 To Items.Count
        With wdApp.documents.Open(Items(i))
            ar(i, 1) = i
            ar(i, 2) = Left(.Paragraphs(3).Range.Text, Len(.Paragraphs(3).Range.Text) - 1)
            With .tables(1)
                For j = 1 To UBound(br)
                    strRngText = Left(.Range.Cells(br(j, 1)).Range.Text, Len(.Range.Cells(br(j, 1)).Range.Text) - 2)
                    ar(i, br(j, 2)) = strRngText
                Next j
            End With
            .Close False
        End With
    Next i
   
    [A1].CurrentRegion.Offset(1).Clear
    With [A2].Resize(UBound(ar), UBound(ar, 2))
        .Value = ar
        .WrapText = True
        .EntireRow.AutoFit
        .VerticalAlignment = xlCenter
    End With
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Set Items = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

1013182120

gwjkkkkk 发表于 2024-4-6 11:19
请参考附件。。。

谢谢老师的帮助，看了挺好的，后续还会有提取其他的内容的话，需要在br = [{2,3;4,4;6,5;8,6;12,7;14,8;16,9;21,10;23,11;25,12;27,13;29,14;31,15;34,16;36,17;38,18;39,19}]这里面添加吧

gwjkkkkk

1013182120 发表于 2024-4-6 13:10
谢谢老师的帮助，看了挺好的，后续还会有提取其他的内容的话，需要在br = [{2,3;4,4;6,5;8,6;12,7;14,8;1 ...

对的，这个要重新定位。。。

1013182120

谢谢老师

1013182120

gwjkkkkk 发表于 2024-4-6 13:11
对的，这个要重新定位。。。

5;8,6;12,7;14,8;老师
请教下这几个我看表格是挨着的  怎么后面是8  12  14

gwjkkkkk

这个一句二句说不清楚，关于word表格定位的问题，有二种方法，你可去word版块去看一下。。。