将word中表格批量导入到Excel
2016-05-17 17:07
429 查看
Sub WordTabletoExcel()
Dim WordApp As Object, DOC, mTable, Fn$, Str$
On Error Resume Next '设置容错代码
CreateObject("wscript.shell").Run "cmd.exe /c dir """ & ThisWorkbook.Path & "\*.doc"" /s/b>""" & ThisWorkbook.Path & "\list.txt""", False, True '取得指定目录下的word文档清单
Set WordApp = CreateObject("word.application") '创建word程序项目(用于操作word文档)
WordApp.Visible = True '设定word程序项目可见
Open ThisWorkbook.Path & "\list.txt" For Input As #1 '打开清单文件并读取内容
While Not EOF(1) '循环读取清单文件各行内容
Input #1, Str '输入一行文本到变量str中
If Trim(Str) <> "" Then '如果文本有效则
Set DOC = WordApp.Documents.Open(Trim(Str)) '利用word程序项目打开对应的word文档
With DOC
For Each mTable In .Tables '循环文档中的各个表格
If Mid(mTable.Cell(1, 1).Range.Text, 1, 4) = "水库名称" and Mid(mTable.Cell(1, 1).Range.Text, 1, 4)
<> "水库名称" Then '判断第一行第一列的名称
'整个表格复制
WordApp.Activate '激活word程序,使之窗体前置
mTable.Range.Copy '复制表格区域
With Windows(1) '激活excel程序窗体,使之前置
.Activate
With ThisWorkbook.ActiveSheet '选中当前使用区A列下面的第一个单元格,并粘贴复制的word中的表格数据
.Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1).Select
.Paste
End With
End With
'获取某个关键字值
For Each MyRng In MyTable.Range.Cells
With MyRng.Range.Find
.Text = "关键字"
.Execute
If .Found Then
Sheets(1).[b65536].End(3).Offset(1) = Replace(MyRng.Next.Range, Chr(7), "")
End If
End With
Next MyRng
End If
Next mTable
.Close False '关闭word文档
End With
End If
Wend
Close #1 '关闭清单文件
If Dir(ThisWorkbook.Path & "\list.txt") <> "" Then Kill ThisWorkbook.Path & "\list.txt" '删除清单文件
WordApp.Quit 'word程序项目关闭
Set DOC = Nothing '清空对应项目变量
Set WordApp = Nothing
End Sub
如果是一个word中的,复制粘贴。
如果是多个word中的,需要写个代码(如下),或者在网上找一下相关的工具。 此方法适用于多个word文档里面的所有表格: 1、将多个含有表格的word文档放入一个目录; 2、在该目录中新建一个空的excel表格; 3、在excel表格中运行以下宏命令,即可。
Sub WordTabletoExcel()
Dim WordApp As Object, DOC, mTable, Fn$, Str$
On Error Resume Next '设置容错代码
CreateObject("wscript.shell").Run "cmd.exe /c dir """ & ThisWorkbook.Path & "\*.doc"" /s/b>""" & ThisWorkbook.Path & "\list.txt""", False, True '取得指定目录下的word文档清单
Set WordApp = CreateObject("word.application") '创建word程序项目(用于操作word文档)
WordApp.Visible = True '设定word程序项目可见
Open ThisWorkbook.Path & "\list.txt" For Input As #1 '打开清单文件并读取内容
While Not EOF(1) '循环读取清单文件各行内容
Input #1, Str '输入一行文本到变量str中
If Trim(Str) <> "" Then '如果文本有效则
Set DOC = WordApp.Documents.Open(Trim(Str)) '利用word程序项目打开对应的word文档
With DOC
For Each mTable In .Tables '循环文档中的各个表格
If Mid(mTable.Cell(1, 1).Range.Text, 1, 4) = "水库名称" and Mid(mTable.Cell(1, 1).Range.Text, 1, 4)
<> "水库名称" Then '判断第一行第一列的名称
'整个表格复制
WordApp.Activate '激活word程序,使之窗体前置
mTable.Range.Copy '复制表格区域
With Windows(1) '激活excel程序窗体,使之前置
.Activate
With ThisWorkbook.ActiveSheet '选中当前使用区A列下面的第一个单元格,并粘贴复制的word中的表格数据
.Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1).Select
.Paste
End With
End With
'获取某个关键字值
For Each MyRng In MyTable.Range.Cells
With MyRng.Range.Find
.Text = "关键字"
.Execute
If .Found Then
Sheets(1).[b65536].End(3).Offset(1) = Replace(MyRng.Next.Range, Chr(7), "")
End If
End With
Next MyRng
End If
Next mTable
.Close False '关闭word文档
End With
End If
Wend
Close #1 '关闭清单文件
If Dir(ThisWorkbook.Path & "\list.txt") <> "" Then Kill ThisWorkbook.Path & "\list.txt" '删除清单文件
WordApp.Quit 'word程序项目关闭
Set DOC = Nothing '清空对应项目变量
Set WordApp = Nothing
End Sub
相关文章推荐
- 使用Python生成Excel格式的图片
- Excel 曝出 Power Query 安全漏洞,1.2 亿用户易受远程 DDE 攻击
- VBA将excel数据表生成JSON文件
- excel vba 限制工作表的滚动区域代码
- excel vba 高亮显示当前行代码
- 微软Word 2007数学插件 Microsoft Math 提供下载
- Office Word九条常用技巧
- SQL 导入导出Excel数据的语句
- C#实现简单合并word文档的方法
- 文本、Excel、Access数据导入SQL Server2000的方法
- powershell操作word详解
- C#实现Excel动态生成PivotTable
- C#生成Word文档代码示例
- C#导出数据到Excel文件的方法
- Vbscript生成Excel报表的常用操作总结
- 用vbscript把 Word 文档保存为文本文件的代码
- 如何使用C#从word文档中提取图片
- C#根据Word模版生成Word文件