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

柳眉儿

jX5EXL08.rar (104.56 KB, 下载次数: 673)

2007-12-3 16:08 上传

点击文件名下载附件
[求助]请问如何将WORD表格中的内容提取到EXCEL中

守柔老师，您好，我是一个汽车厂的产品管理人员，由于我们厂每种汽车的车型配置表是用WORD文件做的，车型配置表很多，现在我急需要将其中部分内容导入到EXCEL中，请您指导，非常感谢。

由于VBA我很差劲，目前我采用的方法如下：
1、将WORD文件用软件一次性全部转化为网页文件
2、将网页文件改后缀名为“XLS”。（这样EXCEL就能打开了它们了）。
3、借用您的一段代码，将所有转换过来的EXCEL文件集中到一个文件中，即一个文件占用一个工作表。
4、新建一个表，再利用公式将所有工作表中的需提取的内容提取到该表中。

但这种方法有以下敝端：
1、操作复杂，需要进行好几步。
2、每次只能转化60个左右的文件，如果再多了，上述第3步时EXCEL就报错。

我是想如果用VBA能实现以下的功能就好了：
1、运行宏后，自动弹出对话框，提示选择需要提取内容的文件。
2、选取所需要的文件后，可一次性将需要提取的内容提取的EXCEL中。

我需要转换的产品配置表示例内容见附件。再次感谢。

守柔

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-12-4 6:48:49
'仅测试于System: Windows NT Excel: 11.0 Language: 2052
'№ 0278^The Code CopyIn [Moudle-Getdoc_Table]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
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(7) As String
    On Error Resume Next
    '定义一个一维数组
    strArray = Array("车型代号", "整车编号", "内部尺寸", "发动机型号", "轴距(mm)", "车身", "变速箱(型式/型号)", "型式/型号")
    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(5, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(2) = Replace(.Cell(13, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(3) = Replace(.Cell(15, 5).Range.Text, Chr(13) & Chr(7), "")
                    myArray(4) = Replace(.Cell(16, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(5) = Replace(.Cell(22, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(6) = Replace(.Cell(26, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(7) = Replace(.Cell(29, 4).Range.Text, Chr(13) & Chr(7), "")
                End With
                wdDoc.close False
                Set xlSheet = ThisWorkbook.Sheets.Add '插入工作表
                With xlSheet
                    .Name = myArray(1)
                    .[A1:H1].Value = strArray '为单元格区域赋值
                    .[A2:H2].Value = myArray '为单元格区域赋值
                    .[A1:H2].Font.Name = "华文细黑" '以下均为格式设置
                    .[A1:H2].Font.Size = 11
                    .[A1:H2].Columns.AutoFit
                    With .[A1:H2].Borders(xlEdgeLeft)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
                    With .[A1:H2].Borders(xlEdgeTop)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
                    With .[A1:H2].Borders(xlEdgeBottom)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
                    With .[A1:H2].Borders(xlEdgeRight)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
                    With .[A1:H2].Borders(xlInsideVertical)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
                    With .[A1:H2].Borders(xlInsideHorizontal)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                    End With
                End With
            Next
        End If
    End With
    wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True '恢复屏幕更新
End Sub
'----------------------

见附件：

ecY9qk99.rar (11.76 KB, 下载次数: 614)

2007-12-4 07:07 上传

点击文件名下载附件

[此贴子已经被作者于2007-12-4 7:07:11编辑过]

tangcong

续貂：引用守柔老师的宏，并同时按楼主意思汇总至一个表中(代码改动部分已突出显示)

Option Explicit
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(7) As String, r As Integer
    On Error Resume Next
    '定义一个一维数组
    strArray = Array("车型代号", "整车编号", "内部尺寸", "发动机型号", "轴距(mm)", "车身", "变速箱(型式/型号)", "型式/型号")
    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(5, 2).Range.Text, Chr(13) & Chr(7), "")
                    myArray(2) = Replace(.Cell(13, 4).Range.Text, Chr(13) & Chr(7), "")
                    myArray(3) = Replace(.Cell(15, 5).Range.Text, Chr(13) & Chr(7), "")
                    myArray(4) = Replace(.Cell(16, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(5) = Replace(.Cell(22, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(6) = Replace(.Cell(26, 3).Range.Text, Chr(13) & Chr(7), "")
                    myArray(7) = Replace(.Cell(29, 4).Range.Text, Chr(13) & Chr(7), "")
                End With
                wdDoc.Close False

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

[此贴子已经被作者于2007-12-4 10:22:30编辑过]

tangcong

请问守柔老师：

将指定的单元格内容赋值给数组时，myArray(0) = Replace(.Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")

等号右边是怎么解释的，我没看懂

[此贴子已经被作者于2007-12-4 10:26:27编辑过]

守柔

QUOTE:

以下是引用tangcong在2007-12-4 10:25:58的发言：

请问守柔老师：

将指定的单元格内容赋值给数组时，myArray(0) = Replace(.Cell(3, 2).Range.Text, Chr(13) & Chr(7), "")

等号右边是怎么解释的，我没看懂

Word中返回单元格数据时，除了单元格内容外，还包含单元格结束标记（CHR(13)和右侧的单元格右侧竖线(CHR(7))，因此，在返回值的过程中，可以使用替换（REPLACE）、文本提取（如MID，LEFT，结合LEN等函数）或者使用Word RANGE方法等进行取值，以去除这两个字符串。

柳眉儿

非常感谢守柔老师以及tangcong老师能在这么短的时间内给我回复，尤其是守柔老师，这么早就在网上了，真是太感谢了。辛苦您了。

运行后完全满足我工作的需要。再次感谢了。

[em17][em44]

XUZHANCHENG

厉害啊,学习了

wangvivian

为什么我一运行就报错呢?找不到工程或库

守柔

QUOTE:

以下是引用wangvivian在2007-12-14 20:11:42的发言：

为什么我一运行就报错呢?找不到工程或库

因为你没有细看代码注释。

Option Explicit
Sub GetDocTablletoSheet()
'请在EXCEL VBE中引用MS WORD
在EXCEL中，按【ALT+F11】组合键，进入VB编辑器，单击【工具】/【引用】命令，打开【引用-Project】对话框，在【引用】中勾选对于【Microsoft Word 11.0 Objict Library】的引用。

wangvivian

谢谢守柔大哥这样及时的回复。我找到了！！
买了本您的大作，正在拜读中。。。