我有几百个word，里面包含有表格，如何批量提取我想要的第一个表格
有这样的word很多，只想取每个word里面的第一个表格到excel里面。每天都需要统计到excl里面。如何实现？听说vba可以，但是没接触过！跪求高手赐教！感激涕零！！！！谢谢
如果是一个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 '循环文档中的各个表格
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
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文档里面的所有表格：
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 '循环文档中的各个表格
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
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追问
您好，这个的确可以，但是这个宏是提取全部表，我想改为提取第一个表，不知道怎么改
温馨提示：内容为网友见解，仅供参考
第1个回答 2018-08-04
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 = false '设定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
Who=-1 '标记要提取哪个表格
Ti=-1'当前表格序号
For Each mTable In .Tables '循环文档中的各个表格
Ti=Ti+1
if Ti=Who 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
Break '提取指定表格后，提前退出循环
end if
End With
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
msgbox "处理完毕！" & vbCrlf & "更多批量处理实用功能，请参见 百宝箱V10.0",64，“消息"
End Sub
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 = false '设定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
Who=-1 '标记要提取哪个表格
Ti=-1'当前表格序号
For Each mTable In .Tables '循环文档中的各个表格
Ti=Ti+1
if Ti=Who 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
Break '提取指定表格后，提前退出循环
end if
End With
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
msgbox "处理完毕！" & vbCrlf & "更多批量处理实用功能，请参见 百宝箱V10.0",64，“消息"
End Sub
第2个回答 2018-08-01
用vba可以做到，秒提追问
该怎么写呢？现在不知道怎么写宏
追答代写
怎么联系？
相似回答
