VBA将Word文档中的表格提取到Excel

最新需要将Word中的表格内容提取到Excel文档中作分析处理。所以动手写了一小段VBA代码来完成数据转换工作，于是将它记录下来，一来方便自己以后查看，另外有需要的朋友也可拿去用。

VBA代码：

Sub WordTable2Excel()

'

' TableToExcel 宏

'

'Dim i As Integer

Dim tablecount As Integer '表格总数

Dim appexcel As Object 'Excel Application Object

Dim appbook  As Object 'Excel book

Dim appsheet  As Object 'Excel book sheet

'新建电子表格的所需

Set appexcel = CreateObject("excel.application")

'先要新建一个电子表格

Set appbook = appexcel.Workbooks.Add

 appbook.Worksheets.Add.Name = "1"

'取出word的文件名，好像有直接的记得好象是shourtname还是什么来着，不管了：》

Dim docname As String

'获取总表格数

tablecount = ActiveDocument.Tables.Count

docname = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)

'没有sheet的表格不会新建，只好手动删了：》

 appexcel.Worksheets("Sheet1").Delete

 appexcel.Worksheets("Sheet2").Delete

 appexcel.Worksheets("Sheet3").Delete

 For i = 1 To tablecount         '设置循环次数

      ActiveDocument.Select

      Selection.Tables(i).Select '选中表格

      Selection.Copy  '表格复制

      If i > 1 Then appbook.Worksheets.Add.Name = i '在删除的上面新建了第一个所以避开第一个

'插入的都是第一个所以这里没有写I，可以用insert after,这样就能换成i了

     appbook.Worksheets(1).Range("A1").Select

     appbook.Worksheets(1).Paste ' 在当前excel粘贴

'情空剪切板

     appexcel.Application.CutCopyMode = False

'这个其实没有必要，是在立即窗口显示的。

     Debug.Print "第" & i & "张表，" & "共" & tablecount & "张"

Next

    '这个就是保存，退出了。

    appbook.SaveAs Path & docname & ".xls"

    appbook.Close

    appexcel.Quit

End Sub