[求助]请问如何将多个WORD表格中的内容提取到EXCEL中 失望中。。。。。。

slayerwwj

本人初学,对VBA不熟,用EXECL也是停留在简单计算阶段.现有一问题求助各位大侠!

同以下的问题相似,几经修改后,也不得其解!
http://club.excelhome.net/thread-283395-1-1.html

单位有>100份个人信息WORD表格, 要依据表格做成名册表. 具体信息全在WORD里.
也就是说, 从WORD表中提取部分数据汇总到一个EXECL表格中.

希望版主和大侠能做好个自动提取的文件给我.不胜感谢!

示列文件在附件中,红色字段为要提取的内容.

[ 本帖最后由 slayerwwj 于 2009-10-18 08:19 编辑 ]

slayerwwj

急啊,.....................................................

slayerwwj

还好,自己解决,还有问题啊........

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(10) 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(1, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(1) = Replace(.Cell(1, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(2) = Replace(.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(3) = Replace(.Cell(5, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(4) = Replace(.Cell(5, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(5) = Replace(.Cell(7, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(6) = Replace(.Cell(8, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(7) = Replace(.Cell(8, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(8) = Replace(.Cell(24, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(9) = Replace(.Cell(26, 2).Range.Text, Chr(13) & Chr(7), "")
                    
                End With
                wdDoc.Close False


                r = r + 1 '以下开始稍作更改
                Sheets(1).Range(Cells(r, 1), Cells(r, 11)).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

抄代码,但问题如下:
我的WORD文件里有二张表格,如何提取第二个表的内容?
以上代码中且粗体表示的就是第二个表格要提取的内容, 但返回是空的.....

期待高人出手中.....

[ 本帖最后由 slayerwwj 于 2009-10-16 10:26 编辑 ]

slayerwwj

几天过去了， 还是

一个人的舞台。。。。。。。。。。。。。。。。。。。

是论坛是败落了？ 还是我的问题太简单了？

slayerwwj

还是自己解决了，虽然不完善。
代码修改如下：
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(1, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(1) = Replace(.Cell(1, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(2) = Replace(.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(3) = Replace(.Cell(5, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(4) = Replace(.Cell(5, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(5) = Replace(.Cell(7, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(6) = Replace(.Cell(8, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(7) = Replace(.Cell(8, 4).Range.Text, Chr(13) & Chr(7), "")
                End With
               
                Set wdTable = wdDoc.Tables(2)
                With wdTable '将指定的单元格内容赋值给数组
                    myArray(8) = Replace(.Cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(9) = Replace(.Cell(3, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(10) = Replace(.Cell(7, 2).Range.Text, Chr(13) & Chr(7), "")
                End With
                wdDoc.Close False


                r = r + 1 '以下开始稍作更改
                Sheets(1).Range(Cells(r, 1), Cells(r, 11)).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

最后要再说一些废话，

论坛是一天不如一天了

李子然

最后要再说一些废话，

论坛是一天不如一天了

支持兄弟，我原来经常泡这个论坛，但前段时间发现打开这个论坛非常慢，可以说简直就是痛苦，先以为是自己的电脑和网络有问题，以是登陆其他网站进行测试飞快，后来到单位的电脑上登录excelhome仍让一哭无泪，没办法一起受折磨不如闪人！
补充一点不是一天不如一天，是彻底不行了。

4me

通用的word表格到excel,打开word表格，只需在excel的第一行填入所需的列名，再执行excel里的vba。
需要生成的文件.rar (12.32 KB, 下载次数: 516)

2009-10-20 22:28 上传

点击文件名下载附件

[ 本帖最后由 4me 于 2009-10-20 22:34 编辑 ]

dogseye

确实牛，但不知道原理是什么，能否解释一下？

blue_prince

4me 发表于 2009-10-20 22:28
通用的word表格到excel,打开word表格，只需在excel的第一行填入所需的列名，再执行excel里的vba。

4me 老师，我运用您作的这个宏，怎么老是提示ActiveX 部件不能创建对象，请问这是为什么，请老师帮助解答，谢谢！

4159888

getobject(,"word.application")运行不通过，
能不能逐句解释一下？