Excel与Word数据交互【带案例】

云海拾贝

梧叶沙沙 发表于 2019-11-6 13:03
案例一：Excel提取Word表格简历

以下为Word简历表中的具体结构，需要批量提取到Excel中。这里面就是 ...

案例1和案例2如何整合一次性完成？

云海拾贝

梧叶沙沙 发表于 2019-11-6 13:03
案例一：Excel提取Word表格简历

以下为Word简历表中的具体结构，需要批量提取到Excel中。这里面就是 ...

案例一中，word第二页和第一页有换行符，第二页表格如何定义？

考试加油站

有空深入学习，谢谢分享

陈功

谢谢分享，学习一下

gaolzhen

谢谢楼主分享

守护天使0315

感谢楼主分享

gwjkkkkk

谢谢老师分享,努力学习。。。

zyq8200

谢谢楼主分享

potato14

梧叶沙沙 发表于 2019-11-6 15:25
欢迎补充！

我有一个从word读取数据的vba，不能运行。能不能帮忙看一下。

potato14

Sub 从Word中提取数据到Excel中()
  Dim WrdDocApp As Object, FSO As Object, wordFilePath, wordFilename, arr(), i&, j&, k1&, k2&, r&, rr&
  Application.ScreenUpdating = False
  Set WrdDocApp = CreateObject("Word.Application")    '用Set关键词创建Word应用程序对象！
  Set FSO = CreateObject("Scripting.FileSystemObject") '文件系统对象
  Set wordFilePath = FSO.GetFolder(ThisWorkbook.Path)  '获取文件夹的路径
  
  wordFilename = Dir(wordFilePath & "\*.doc*") '循环查找Word,可以适应不同版本 具体提取哪类文件,根据文件扩展名进行处理
  Do While wordFilename <> ""  '在目录中循环
   
  On Error Resume Next
'  WrdDocApp.Visible = False 'Word应用程序不可见
'  Set WrdDoc = WrdDocApp.Documents.Open(wordFilePath & "\" & wordFilename)    '打开这个Word文件！
  Set WrdDoc = GetObject(wordFilePath & "\" & wordFilename) '使用此代码 ,打开Word文件 视窗会自动隐藏(给人的感觉是没有打开做的操作)
  
  With WrdDoc.Tables(1) '提取Word文件内第1页的第1个表格内容
    For i = 5 To .Rows.Count  '在第1个表格中从第5行到总行数中循环
      If WorksheetFunction.Clean(.cell(i, 1).Range.Text) = "收件人：" Then  '第1个收货人
        Exit For
      Else
        If WorksheetFunction.Clean(.cell(i, 1).Range.Text) <> "" Then k1 = k1 + 1 '得到第1个型号的个数
      End If
    Next i
   
   
    If k1 > 0 Then  '型号的个数不等于0
        ReDim arr(1 To k1, 1 To 10)  '重新定义数组arr
        If k1 > 0 Then '第1个型号的个数大于0
          arr(1, 1) = WorksheetFunction.Clean(.cell(1, 2).Range.Text) '客户名称
          arr(1, 2) = WorksheetFunction.Clean(.cell(1, 4).Range.Text) '发货日期
          arr(1, 3) = WorksheetFunction.Clean(.cell(2, 2).Range.Text) '收件人
          arr(1, 4) = WorksheetFunction.Clean(.cell(6, 1).Range.Text) '合同号
          arr(1, 5) = WorksheetFunction.Clean(.cell(6, 2).Range.Text) '产品名称
          arr(1, 6) = WorksheetFunction.Clean(.cell(6, 3).Range.Text) '产品型号
          arr(1, 7) = WorksheetFunction.Clean(.cell(6, 5).Range.Text) '数量
          arr(1, 8) = WorksheetFunction.Clean(.cell(6, 6).Range.Text) 'T8订单号
         
        End If
        
        If k1 > 1 Then '第1个型号的个数大于1
          For r = 1 To k1 - 1  '提取第1个型号之后的
            arr(r + 1, 4) = WorksheetFunction.Clean(.cell(5 + r, 1).Range.Text) '合同号
            arr(r + 1, 5) = WorksheetFunction.Clean(.cell(5 + r, 2).Range.Text) '产品名称
            arr(r + 1, 6) = WorksheetFunction.Clean(.cell(5 + r, 3).Range.Text) '产品型号
            arr(r + 1, 7) = WorksheetFunction.Clean(.cell(5 + r, 5).Range.Text) '数量
            
          Next r
        End If
        
      
        End If
      
    End With
    Range("A" & Cells(Rows.Count, 4).End(3).Row + 1).Resize(k1, 10) = arr '把提取的内容赋值给Excel工作表
    Erase arr  '重新初始化arr数组
    k1 = 0: ''重新k1,k2
    With Range("A2:J" & Cells(Rows.Count, 4).End(3).Row) '设定格式
    .Font.Size = 11: .Borders.Value = 1
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    End With
    Range("H2:H" & Cells(Rows.Count, 4).End(3).Row).HorizontalAlignment = xlLeft  '设定格式
    Columns("A:J").EntireColumn.AutoFit '自动栏宽
'  WrdDoc.Close    ' 关闭Word文件
    WrdDocApp.Quit  '关闭Word程序
    Set WrdDocApp = Nothing '释放Word程序
    wordFilename = Dir
  Loop '结束循环
Application.ScreenUpdating = True
End Sub