快崩溃了，如何从几千个相同的WORD文件中提取相应的文字和数值到EXCEL里。

mikezhu58

几千个相同的WORD文档，但我现在只需要其中的几个数据值，如姓名、个人ID、电话、户籍地址、居住地址，提取到一个excel表中并分列显示，我现在用最原始的方式一条一条复制粘贴，手都要断了，而且工作催要的很急，没办法了。我只有请教本坛的达人了，帮助一个能 需要样式.rar (67.75 KB, 下载次数: 51)

2015-3-5 13:30 上传

点击文件名下载附件
就是这样子

处理的方法。先谢谢大家了！！

mikezhu58

经过自己学习本坛达人的VBA，现摸索出来了一点点，能抽取一行数据，但一个文档里的另几个同样的表格和同样数据则不能提取。真心希望本坛的老师们能帮助我，谢谢了。
下面是学习老师们的VBA:
Sub GetDocTablletoSheet()
'请在EXCEL VBE中引用MS WORD
    Dim wdApp As Word.Application, wdDoc As Word.Document, wdTable As Word.Table
    Dim strArray() As Variant, xlSheet As Worksheet, myDialog As FileDialog, oSel As Variant
    Dim myArray(11) As String, r As Integer
    On Error Resume Next
    '定义一个三维数组
    strArray = Array("姓名", "居民身份证号", "联系电话", "户籍地址", "实际居住地址")
    Set wdApp = New Word.Application '取得一个New Word对象
   
    Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
    With myDialog
        .Filters.Clear    '清除所有文件筛选器中的项目
        .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
        .AllowMultiSelect = True    '允许多项选择
        If .Show = -1 Then    '确定
        
        Application.ScreenUpdating = False
        
            For Each oSel In .SelectedItems    '在所有选取项目中循环
                Set wdDoc = wdApp.Documents.Open(Filename:=oSel, Visible:=False)
                Set wdTable = wdDoc.Tables(1)
                With wdTable '将指定的单元格内容赋值给数组
                    myArray(0) = Replace(.Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(1) = Replace(.Cell(7, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(2) = Replace(.Cell(2, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(3) = Replace(.Cell(8, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(4) = Replace(.Cell(9, 2).Range.Text, Chr(13) & Chr(7), "")
                End With
                Set wdTable = wdDoc.Tables(2)
                With wdTable '将指定的单元格内容赋值给数组
                    myArray(14) = Replace(.Cell(14, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(18) = Replace(.Cell(18, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(13) = Replace(.Cell(13, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(19) = Replace(.Cell(19, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(10) = Replace(.Cell(20, 2).Range.Text, Chr(13) & Chr(7), "")
                End With
                wdDoc.Close False


                r = r + 1 '以下开始稍作更改
                Sheets(1).Range(Cells(r, 1), Cells(r, 5)).Value = myArray '为单元格区域赋值
            Next
            With Sheets(1)
                .Rows(1).Insert
                .[A1:H1].Value = strArray
                .UsedRange.Columns.AutoFit
            End With
        End If
    End With
    wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub

loquat

楼主的表格好像有点不规范。。。
如果表格规范的话，应该这样就可以的。
Sub test()
Application.ScreenUpdating = False
Dim aCount&, aTable As Table
Dim arr, brr, i&
With ThisDocument
    aCount = .Tables.Count
    ReDim arr(1 To aCount, 1 To 5)
    For i = 1 To aCount
        Set aTable = .Tables(i)
        brr = Split(aTable.Range.Text, Chr(7))
        arr(i, 1) = Left(brr(39), Len(brr(39)) - 1)
        arr(i, 2) = Left(brr(13), Len(brr(13)) - 1)
        arr(i, 3) = Left(brr(8), Len(brr(8)) - 1)
        arr(i, 4) = Left(brr(44), Len(brr(44)) - 1)
        arr(i, 5) = Left(brr(49), Len(brr(49)) - 1)
    Next
End With
Set aExcel = GetObject(, "Excel.Application")
Set aBook = aExcel.workbooks("需导入表样式.xls")
Set aSheet = aBook.worksheets("高地巷1-4号")
aSheet.Range("A2").Resize(aCount, 5) = arr
Application.ScreenUpdating = True
End Sub

loquat

楼主的表格有重叠，就懒得写代码了，提示一下吧。
像这种情况只能使用find方法来查询，配合selection来取值。
因为表格有重叠，考虑到要去重，最好使用字典。

mikezhu58

谢谢你的帮助，但我没有能力，也就是您所教的方法。如果可能的话，请您帮助写一个吧，请以我补充
上传的那个包做类比，（可能你没有打开我补充上传的那个包吧）因一个Word里有些有3-4个相同文档，
但正如您所说是不规范的。我一点办法都没有了。

cuteword

这种文档是否是扫描得到的？

008zhang

如果文档规范，很容易解决

mikezhu58

不是扫描的，给我就是Word的了。可能是输入的人学习不太认真吧，输入张贴表格时就不规范。

1261181315a

loquat 发表于 2015-3-6 23:07
楼主的表格好像有点不规范。。。
如果表格规范的话，应该这样就可以的。
Sub test()

为何我尝试时有下标超界？请loquat解释下，谢谢

1261181315a

1261181315a 发表于 2015-3-8 22:33
为何我尝试时有下标超界？请loquat解释下，谢谢

请问楼主利用代码完成了工作了吗？请分享一下啊