万分感激，有相同的word，需要提取相同的信息汇总到Excel中，好几天了不会啊

gaochao815

新建 Microsoft Excel 工作表.zip (4.21 KB, 下载次数: 11)

2015-3-21 21:34 上传

点击文件名下载附件
汇总

      需要单表的各项比如 姓名 身份证号 性别等 汇总到EXCEL中

gaochao815

看到有老师这样帮助别人弄类似的文件，我实在看不懂，有老师能讲解下吗？
Sub test()
Dim i%, ar(1 To 60000, 1 To 20), ttt$, brr()
Dim wordApp As Object, myword As Object, t As Object
Application.ScreenUpdating = False
Set wordApp = CreateObject("Word.Application")
Set myword = wordApp.Documents.Open(ThisWorkbook.Path & "\全省项目排版1014.doc")
wordApp.Visible = 0
On Error Resume Next
ReDim brr(1 To myword.Tables.Count)
For Each t In myword.Tables
    If t.Rows.Count < 19 Then
        
        j = 0
        ttt = t.Cell(j + 1, 1).Range.Text
        Do While InStr(ttt, "名称") = 0
        j = j + 1
            ttt = t.Cell(j + 1, 1).Range.Text
            If j = 5 Then Exit Do
        Loop
        If j < 4 Then
        i = i + 1
            ar(i, 1) = t.Cell(1 + j, 2).Range.Text
            ar(i, 2) = t.Cell(2 + j, 2).Range.Text
            ar(i, 3) = t.Cell(3 + j, 3).Range.Text
            ar(i, 4) = t.Cell(3 + j, 5).Range.Text
            ar(i, 5) = t.Cell(4 + j, 3).Range.Text
            ar(i, 6) = t.Cell(5 + j, 3).Range.Text
            ar(i, 7) = t.Cell(6 + j, 3).Range.Text
            ar(i, 8) = t.Cell(6 + j, 5).Range.Text
            ar(i, 9) = t.Cell(7 + j, 3).Range.Text
            ar(i, 10) = t.Cell(8 + j, 3).Range.Text
            ar(i, 11) = t.Cell(9 + j, 3).Range.Text
            ar(i, 12) = t.Cell(9 + j, 5).Range.Text
            ar(i, 13) = t.Cell(10 + j, 3).Range.Text
            ar(i, 14) = t.Cell(11 + j, 3).Range.Text
            ar(i, 15) = t.Cell(12 + j, 2).Range.Text
            ar(i, 16) = t.Cell(13 + j, 2).Range.Text
            ar(i, 17) = t.Cell(14 + j, 3).Range.Text
            ar(i, 18) = t.Cell(14 + j, 5).Range.Text
            ar(i, 19) = t.Cell(15 + j, 3).Range.Text
            ar(i, 20) = t.Cell(15 + j, 5).Range.Text
        End If
    ElseIf t.Rows.Count > 18 Then
        For j = 1 To t.Rows.Count Step 18
            i = i + 1
            ar(i, 1) = t.Cell(1 + 3, 2).Range.Text
            ar(i, 2) = t.Cell(2 + 3, 2).Range.Text
            ar(i, 3) = t.Cell(3 + 3, 3).Range.Text
            ar(i, 4) = t.Cell(3 + 3, 5).Range.Text
            ar(i, 5) = t.Cell(4 + 3, 3).Range.Text
            ar(i, 6) = t.Cell(5 + 3, 3).Range.Text
            ar(i, 7) = t.Cell(6 + 3, 3).Range.Text
            ar(i, 8) = t.Cell(6 + 3, 5).Range.Text
            ar(i, 9) = t.Cell(7 + 3, 3).Range.Text
            ar(i, 10) = t.Cell(8 + 3, 3).Range.Text
            ar(i, 11) = t.Cell(9 + 3, 3).Range.Text
            ar(i, 12) = t.Cell(9 + 3, 5).Range.Text
            ar(i, 13) = t.Cell(10 + 3, 3).Range.Text
            ar(i, 14) = t.Cell(11 + 3, 3).Range.Text
            ar(i, 15) = t.Cell(12 + 3, 2).Range.Text
            ar(i, 16) = t.Cell(13 + 3, 2).Range.Text
            ar(i, 17) = t.Cell(14 + 3, 3).Range.Text
            ar(i, 18) = t.Cell(14 + 3, 5).Range.Text
            ar(i, 19) = t.Cell(15 + 3, 3).Range.Text
            ar(i, 20) = t.Cell(15 + 3, 5).Range.Text
        Next
    End If
Next
myword.Close False
wordApp.Quit
Set wordApp = Nothing
Set myword = Nothing
ActiveSheet.UsedRange.Offset(2).ClearContents
With [a3].Resize(i, 20)
.Value = ar
.Replace Chr(7), "", xlPart
End With
Application.ScreenUpdating = True
End Sub

gaochao815

老师来指点下啊

liangdonghao222

gaochao815 发表于 2015-3-22 11:12
老师来指点下啊

加我一下吧  qq  1871960618

逍遥秀才ONLY

先把需要收集数据的表格拆分出来，拆分成两个部分。然后点击另存为单个网页。记下这个网页的地址。这是第一步
打开excel，我用的2013版的，在数据下面有个自网站，点击自网站，然后在对话框里输入刚记下的网页地址。点击转到，打开要收集数据的表格，点击表格左上角的右方向箭头，将其选中，点击导入数据，然后就根据自己的要求进行调节了。