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

xykoo

如何将WORD里面的姓名和参加工作时间提取到新建EXCEL里？由于每个人都是一张表，人工操作费时费力。请求高手们帮助，谢谢。

duquancai

有空的时候再给你服务。好吗？

xykoo

duquancai 发表于 2018-3-19 14:00
有空的时候再给你服务。好吗？

您客气了，谢谢啊！

xykoo

谢谢大家，请求帮助。

jiaxinl

xykoo 发表于 2018-3-19 14:55
谢谢大家，请求帮助。

代码如下
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
f = ActiveWorkbook.Path & "\个人审批表\"
  ff = Dir(f & "\*.doc*") '循环查找Word,可以适应不同版本 '具体提取哪类文件,还是需要根据文件扩展名进行处理
  Do While ff <> ""  '在目录中循环
    文件路径 = f & "\" & ff  'Word文件路径
    'Set WrdDocApp = GetObject(, "Word.Application")  'Word程序
    Set WrdDocApp = CreateObject("Word.Application") '如上一个报错则采用这个
    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文件并不保存
     WrdDocApp.Quit  '关闭Word程序
     Set WrdDocApp = Nothing
    ff = Dir
  Loop '结束循环

  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) = 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

xykoo

jiaxinl 发表于 2018-3-19 16:55
代码如下
Sub WordToExcel()
Dim WrdDocApp As Object, brr(), StarTime As Date, EndTime As Date, f$ ...

操作的时候为什么只能提取2个人呢 第三个人无法提取到

jiaxinl

xykoo 发表于 2018-3-19 18:05
操作的时候为什么只能提取2个人呢 第三个人无法提取到

Range("A" & Cells(Rows.Count, 1).End(3).Row + 1).Resize(UBound(brr), 2) = Application.Transpose(brr) '提取的数据赋值给Excel表格

改为

Range("A" & Cells(Rows.Count, 1).End(3).Row + 1).Resize(UBound(brr,2), 2) = Application.Transpose(brr) '提取的数据赋值给Excel表格

duquancai

xykoo 发表于 2018-3-19 14:54
您客气了，谢谢啊！

1. Private Sub CommandButton1_Click()
   
2.     Dim pa$, aDoc As Document, aData$(9000, 1 To 2), f$, Q As Range
   
3.     With Application.FileDialog(msoFileDialogFolderPicker)
   
4.         If .Show Then pa = .SelectedItems(1) Else MsgBox "请选Word所在文件夹": Exit Sub
   
5.     End With
   
6.     f = Dir(pa & "\*.doc*")
   
7.     Do While f <> ""
   
8.         n = n + 1
   
9.         Set aDoc = Documents.Open(pa & "" & f, Visible:=0)
   
10.         Set Q = aDoc.Tables(1).Range.Cells(2).Range
    
11.         aData(n, 1) = aDoc.Range(Q.Start, Q.End - 1)
    
12.         Set Q = aDoc.Tables(1).Range.Cells(10).Range
    
13.         aData(n, 2) = aDoc.Range(Q.Start, Q.End - 1)
    
14.         aDoc.Close 0
    
15.         f = Dir
    
16.     Loop
    
17.     aData(0, 1) = "姓名": aData(0, 2) = "参加工作时间"
    
18.     Dim xlapp As Object, myBook As Object, mysheet As Object, str$
    
19.     Set xlapp = CreateObject("Excel.Application")
    
20.     xlapp.Visible = 0
    
21.     str = xlapp.GetOpenFilename("Excel文件,*.xls*", , "请选择")
    
22.     If str = "False" Then MsgBox "请选Excel文件": Exit Sub
    
23.     Set myBook = GetObject(str): Set mysheet = myBook.sheets(1)
    
24.     mysheet.Cells.Clear: mysheet.Range("a1").Resize(n + 1, 2) = aData
    
25.     myBook.Windows(1).Visible = -1: myBook.Save: myBook.Close 0
    
26.     xlapp.Quit
    
27.     MsgBox "ok!"
    
28. End Sub

复制代码

duquancai

xykoo 发表于 2018-3-19 14:54
您客气了，谢谢啊！

下载文件，打开，点击按钮，ok！

xykoo

jiaxinl 发表于 2018-3-19 18:24
Range("A" & Cells(Rows.Count, 1).End(3).Row + 1).Resize(UBound(brr), 2) = Application.Transpose(br ...

还是不好用呢？