关于多个Word文件中表格内容批量导入Excel的问题

xykoo

xykoo 发表于 2018-3-20 08:04
还是不好用呢？

提取出来了，谢谢。但是时间有点慢 有没有好的方法速度能提升呢？

jiaxinl

xykoo 发表于 2018-3-20 08:08
提取出来了，谢谢。但是时间有点慢 有没有好的方法速度能提升呢？

Sub WordToExcel()
Dim WrdDocApp As Object, brr(), StarTime As Date, EndTime As Date, f$, ff$, x&
StarTime = Timer
Application.ScreenUpdating = False
On Error Resume Next
  'Set WrdDocApp = GetObject(, "Word.Application")  'Word程序
    Set WrdDocApp = CreateObject("Word.Application") '如上一个报错则采用这个
f = ActiveWorkbook.Path & "\个人审批表\"
  ff = Dir(f & "\*.doc*") '循环查找Word,可以适应不同版本 '具体提取哪类文件,还是需要根据文件扩展名进行处理
  Do While ff <> ""  '在目录中循环
    文件路径 = f & "\" & ff  'Word文件路径
    Set WDoc = WrdDocApp.Documents.Open(文件路径) '打开Word
    x = x + 1
    ReDim Preserve brr(1 To 2, 1 To x) '重新定义数组
    With WDoc.Tables(1) '提取Word文件内每1页的第1个表格内容
        brr(1, x) = WorksheetFunction.Clean(.cell(1, 2).Range.Text) '表格的第1行第2列的单元格清除不可见字符后的内容赋值给数组
        brr(2, x) = WorksheetFunction.Clean(.cell(2, 4).Range.Text)
    End With
    WDoc.Close Savechanges:=False '关闭word文件并不保存
    ff = Dir
  Loop '结束循环
     WrdDocApp.Quit  '关闭Word程序
     Set WrdDocApp = Nothing
  Range("A2:B" & Cells(Rows.Count, 1).End(3).Row + 1).Clear
  Range("A" & Cells(Rows.Count, 1).End(3).Row + 1).Resize(UBound(brr,2), 2) = Application.Transpose(brr) '提取的数据赋值给Excel表格

With Range("A1:B" & Cells(Rows.Count, 1).End(3).Row) '设定格式
    .Font.Size = 12: .Borders.Value = 1
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
End With
Columns("A:B").EntireColumn.AutoFit '自动适合栏宽
EndTime = Timer
MsgBox "从Word中批量提取数据已完成！" & Chr(13) & Format(EndTime - StarTime, "程序运行时间约为：0.00秒"), 64, "提取结果"
End Sub

wdpfox

学习一下杜老师的代码,谢谢！

deansun

jiaxinl 发表于 2018-3-20 08:39
Sub WordToExcel()
Dim WrdDocApp As Object, brr(), StarTime As Date, EndTime As Date, f$, ff$, x&
...

搜寻许久终于找到此方法，感谢老师分享，另请问想在一个表格中提取更多项要怎么修改代码