如何从word表格中批量提取数据。

ndt3

各位大神：

      一直以来都有个老大难问题：从word中批量提取数据的问题，以前都是复制粘贴到excl里然后再慢慢删，效率低，由于word的隐藏格式造成有些复制过来表格对应的行列还不一致。论坛里的代码找了很多，表头部分都有解决方法，但是表头下面的就没有相应的代码可供借鉴。
特来求助各位大神！辛苦大神代码注释一下方便理解学习！十分感谢！！！

一、表格实际存储有两种情况：1、每张表格一个文件、2、同一文件有多份

二、蓝色字体表头部分，提取使用上下左右偏移；

三、红色字体条目行数不固定，而且不一定只有5行；使用“荣获情况”作为标记确认行数是否可行，

四、如果:红色字体条目列数变化（增加或者减少）怎么扩展？(所有表格都一样的变动不是动态)

五、取文件名并链接，方便快速打开修改；

详情请参阅附件。谢谢各位大神！

补充内容 (2019-10-15 16:38):
表头部分已经实现，关键正餐，表中部分。。。。求帮助！谢谢各位老师！

ndt3

没人看看么，自己顶一下！

Moneky

可以用我的docpick先将文档根据所含表格的类型进行分类，然后再用doc2xls来分类导入

ndt3

Moneky 发表于 2019-10-12 13:34
可以用我的docpick先将文档根据所含表格的类型进行分类，然后再用doc2xls来分类导入

老师主要是截图部分需要逐条生成，其他的您的工具都能解决，这个有C:\Users\Administrator\Desktop\测试文件\QQ截图20191015153735点麻烦，还是要感谢老师！谢谢！

ndt3

Moneky 发表于 2019-10-12 13:34
可以用我的docpick先将文档根据所含表格的类型进行分类，然后再用doc2xls来分类导入

老师，表头解决了，怎么处理表中呢？麻烦帮忙看看！谢谢！

Moneky

ndt3 发表于 2019-10-15 16:40
老师，表头解决了，怎么处理表中呢？麻烦帮忙看看！谢谢！

导入到Excel中在同一行，然后自己在Excel中手动处理即可。

乐乐2006201505

难度不大，就是费时间。还没有解决的话，说一声，有空帮你看看，最近视力过度疲劳，所以很长时间没来论坛了。

乐乐2006201505

虽然不是很完美，但可以实现你的要求了，没想到竟然花了近4个小时，看来水平还亟待提高
Sub GetDocTablletoSheet()
  '请在EXCEL VBE中引用MS WORD   http://xysj1980.blog.163.com/blo ... 398201221843054403/
  Dim wdApp As Word.Application, wdDoc As Word.Document, wdTable As Word.Table
  Dim strArray() As Variant, xlSheet As Worksheet, myDialog As FileDialog, oSel As Variant, otb As Table
  Dim myArray() As String, r As Integer, i As Integer, m As Integer, rc As Integer
  For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='WINWORD.EXE'")
    Process.Terminate (0)
  Next
  On Error Resume Next
  r = ActiveSheet.[b65536].End(xlUp).Row
  '定义一个一维数组，给EXCEL数据表表头赋值
  If r > 2 Then
    Range("b2:m" & r).ClearContents
  End If
  r = ActiveSheet.[b65536].End(xlUp).Row
  Set wdApp = New Word.Application '取得一个New Word对象
  Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
  With myDialog
    .Filters.Clear    '清除所有文件筛选器中的项目
    .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
    .AllowMultiSelect = True    '允许多项选择
    If .Show = -1 Then    '确定
      Application.ScreenUpdating = False
      For Each oSel In .SelectedItems    '在所有选取word文档中循环
        m = 8                              '此处数字2即提取word表格中几个数据，亦即提取数据后工作表中列数
        Set wdDoc = wdApp.Documents.Open(Filename:=oSel, Visible:=False)
        For i = 1 To wdDoc.Tables.Count '在一个word文档的所有表格中循环
          Set wdTable = wdDoc.Tables(i)
          With wdTable
            With .Range.Find
              .Text = "荣获情况"
              .Execute
              If .Found = True Then
                rc = wdTable.Range.Rows.Count - 5
              End If
            End With
            For rc1 = rc To 7 Step -1
              If Replace(.cell(rc1, 1).Range.Text, Chr(13) & Chr(7), "") = "" Then
                rc = rc - 1
              End If
            Next
          End With
          rm = rc - 6
          ReDim myArray(1 To rm, 1 To 12) '此处需要加入统计某一内容的行数
          With wdTable '将word文档中指定的单元格内容赋值给数组
            For a1 = 1 To rm
              myArray(a1, 1) = Replace(.cell(1, 2).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 2) = Replace(.cell(1, 4).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 3) = Replace(.cell(1, 6).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 4) = Replace(.cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 5) = Replace(.cell(2, 4).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 6) = Replace(.cell(2, 6).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 7) = Replace(.cell(4, 1).Range.Text, Chr(13) & Chr(7), "")
            Next
            For r1 = 1 To rm
              For r2 = 8 To 12 - 1
                myArray(r1, r2) = Replace(.cell(r1 + 6, r2 - 7).Range.Text, Chr(13) & Chr(7), "")
              Next
            Next
          End With
          With Sheets(1)
            r = .[b65536].End(xlUp).Row + 1
            .Range("B" & r).Resize(UBound(myArray), UBound(myArray, 2)) = myArray  '为单元格区域赋值
            For rn = r To r + rm
              .Hyperlinks.Add Anchor:=Cells(rn, 13), Address:=wdDoc.Name, SubAddress:="", TextToDisplay:="" 'wdDoc.Name '文件名超链接
            Next
          End With
        Next '完成一个文件的赋值
        wdDoc.Close False
      Next
    End If
  End With
  wdApp.Quit
  Set wdApp = Nothing
  Application.ScreenUpdating = True '恢复屏幕更新
End Sub

ndt3

乐乐2006201505 发表于 2019-10-26 23:38
虽然不是很完美，但可以实现你的要求了，没想到竟然花了近4个小时，看来水平还亟待提高
Sub GetDocT ...

谢谢！这个我折腾了快半个月，已经全部完成。
代码借来用用，嘿嘿！

乐乐2006201505

又花了近1天时间，刚刚实现了“荣获情况”行出现在任何一行，都可以实现相同结果的效果。终于自认为比较圆满了。主要是红色部分代码。
Sub GetDocTablletoSheet()
  '请在EXCEL VBE中引用MS WORD   http://xysj1980.blog.163.com/blo ... 398201221843054403/
  Dim wdApp As Word.Application, wdDoc As Word.Document, wdTable As Word.Table
  Dim strArray() As Variant, xlSheet As Worksheet, myDialog As FileDialog, oSel As Variant, otb As Table
  Dim myArray() As String, r As Integer, i As Integer, m As Integer, rc As Integer
  For Each Process In GetObject("winmgmts:").ExecQuery("select * from Win32_Process where name='WINWORD.EXE'")
    Process.Terminate (0)
  Next
  On Error Resume Next
  r = ActiveSheet.[b65536].End(xlUp).Row
  '定义一个一维数组，给EXCEL数据表表头赋值
  If r > 2 Then
    Range("b2:m" & r).ClearContents
  End If
  r = ActiveSheet.[b65536].End(xlUp).Row
  Set wdApp = New Word.Application '取得一个New Word对象
  Set myDialog = Application.FileDialog(msoFileDialogFilePicker)
  With myDialog
    .Filters.Clear    '清除所有文件筛选器中的项目
    .Filters.Add "所有 WORD 文件", "*.doc", 1    '增加筛选器的项目为所有WORD文件
    .AllowMultiSelect = True    '允许多项选择
    If .Show = -1 Then    '确定
      Application.ScreenUpdating = False
      For Each oSel In .SelectedItems    '在所有选取word文档中循环
        m = 8                              '此处数字2即提取word表格中几个数据，亦即提取数据后工作表中列数
        Set wdDoc = wdApp.Documents.Open(Filename:=oSel, Visible:=False)
        For i = 1 To wdDoc.Tables.Count '在一个word文档的所有表格中循环
          Set wdTable = wdDoc.Tables(i)
          With wdTable
            For ii = 1 To .Range.Rows.Count
              If Replace(.cell(ii, 1).Range.Text, Chr(13) & Chr(7), "") = "荣获情况" Then
                rc = ii - 1
                Exit For
              End If
            Next
            For rc1 = rc To 7 Step -1
              If Replace(.cell(rc1, 1).Range.Text, Chr(13) & Chr(7), "") = "" Then
                rc = rc - 1
              End If
            Next
          End With
          rm = rc - 6
          ReDim myArray(1 To rm, 1 To 12) '此处需要加入统计某一内容的行数
          With wdTable '将word文档中指定的单元格内容赋值给数组
            For a1 = 1 To rm
              myArray(a1, 1) = Replace(.cell(1, 2).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 2) = Replace(.cell(1, 4).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 3) = Replace(.cell(1, 6).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 4) = Replace(.cell(2, 2).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 5) = Replace(.cell(2, 4).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 6) = Replace(.cell(2, 6).Range.Text, Chr(13) & Chr(7), "")
              myArray(a1, 7) = Replace(.cell(4, 1).Range.Text, Chr(13) & Chr(7), "")
            Next
            For r1 = 1 To rm
              For r2 = 8 To 12 - 1
                myArray(r1, r2) = Replace(.cell(r1 + 6, r2 - 7).Range.Text, Chr(13) & Chr(7), "")
              Next
            Next
          End With
          With Sheets(1)
            r = .[b65536].End(xlUp).Row + 1
            .Range("B" & r).Resize(UBound(myArray), UBound(myArray, 2)) = myArray  '为单元格区域赋值
            For rn = r To r + rm
              .Hyperlinks.Add Anchor:=Cells(rn, 13), Address:=wdDoc.Name, SubAddress:="", TextToDisplay:="" 'wdDoc.Name '文件名超链接
            Next
          End With
        Next '完成一个文件的赋值
        wdDoc.Close False
      Next
    End If
  End With
  wdApp.Quit
  Set wdApp = Nothing
  Application.ScreenUpdating = True '恢复屏幕更新
End Sub