excel 如何自动提取多个word中固定位置的内容

救赎0003 · 发表于 2017-8-12 20:19

本帖最后由救赎0003 于 2017-8-12 22:31 编辑

合同号

工程名称

销售单号

规格

芯数

数量（KM）

盘数

交货地址

收货人

联系电话

每次有N个word发货单（就上2个暂时），但是里面格式都是固定的，我每次都是一个一个复制内容整理到excel里，可否有大师帮忙制作一个VBA 可以提取一个文件夹里所有合同号，工程名称，销售单号，规格，芯数，数量，盘数，交货地址，收货人，联系人电话。若制作成功，希望能留下联系方式，定会感谢！！！！！

按照大师们写的VBA 我自己改了，运行出现的问题，我应该怎么修改。

jiaxinl · 发表于 2017-8-13 09:13

从Word中提取数据到Excel中---请看动态图及附件
代码如下：
Sub 从Word中提取数据到Excel中()
  Dim WrdDocApp As Object, FSO As Object, wordFilePath, wordFilename, arr()
  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文件视窗会自动隐藏(给人的感觉是没有打开做的操作)

  ReDim arr(1 To 4, 1 To 10) '重新定义数组arr
  With WrdDoc.Tables(1) '提取Word文件内第1页的第1个表格内容
arr(1, 1) = WorksheetFunction.Clean(.cell(1, 4).Range.Text) '合同号
arr(1, 2) = WorksheetFunction.Clean(.cell(2, 2).Range.Text) '工程名称
arr(1, 3) = WorksheetFunction.Clean(.cell(2, 4).Range.Text) '销售单号
arr(1, 4) = WorksheetFunction.Clean(.cell(5, 2).Range.Text) '型号
arr(1, 5) = WorksheetFunction.Clean(.cell(5, 3).Range.Text) '芯数
arr(1, 6) = WorksheetFunction.Clean(.cell(5, 4).Range.Text) '数量
arr(1, 7) = WorksheetFunction.Clean(.cell(5, 5).Range.Text) '盘长及盘数
arr(1, 8) = WorksheetFunction.Clean(.cell(3, 2).Range.Text) '交货地址1
arr(1, 9) = WorksheetFunction.Clean(.cell(7, 2).Range.Text) '收货人1
arr(1, 10) = WorksheetFunction.Clean(.cell(7, 4).Range.Text) '联系电话1

arr(2, 4) = WorksheetFunction.Clean(.cell(6, 2).Range.Text) '型号
arr(2, 5) = WorksheetFunction.Clean(.cell(6, 3).Range.Text) '芯数
arr(2, 6) = WorksheetFunction.Clean(.cell(6, 4).Range.Text) '数量
arr(2, 7) = WorksheetFunction.Clean(.cell(6, 5).Range.Text) '盘长及盘数

arr(3, 4) = WorksheetFunction.Clean(.cell(10, 2).Range.Text) '型号
arr(3, 5) = WorksheetFunction.Clean(.cell(10, 3).Range.Text) '芯数
arr(3, 6) = WorksheetFunction.Clean(.cell(10, 4).Range.Text) '数量
arr(3, 7) = WorksheetFunction.Clean(.cell(10, 5).Range.Text) '盘长及盘数
arr(3, 8) = WorksheetFunction.Clean(.cell(8, 2).Range.Text) '交货地址2
arr(3, 9) = WorksheetFunction.Clean(.cell(12, 2).Range.Text) '收货人2
arr(3, 10) = WorksheetFunction.Clean(.cell(12, 4).Range.Text) '联系电话2

arr(4, 4) = WorksheetFunction.Clean(.cell(11, 2).Range.Text) '型号
arr(4, 5) = WorksheetFunction.Clean(.cell(11, 3).Range.Text) '芯数
arr(4, 6) = WorksheetFunction.Clean(.cell(11, 4).Range.Text) '数量
arr(4, 7) = WorksheetFunction.Clean(.cell(11, 5).Range.Text) '盘长及盘数
End With
Range("A" & Cells(Rows.Count, 4).End(3).Row + 1).Resize(4, 10) = arr '把提取的内容赋值给Excel工作表
Erase arr  '重新初始化arr数组
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

小花鹿 · 发表于 2017-8-13 09:35

你得说明一下，WORD中的序号是不是都是两个......................................................................

救赎0003 · 发表于 2017-8-13 10:10

小花鹿发表于 2017-8-13 09:35
你得说明一下，WORD中的序号是不是都是两个............................................................ ...

有时候是3个序号，型号下有多少提取多少。

救赎0003 · 发表于 2017-8-13 10:13

jiaxinl 发表于 2017-8-13 09:13
从Word中提取数据到Excel中---请看动态图及附件
代码如下：
Sub 从Word中提取数据到Excel中()

我不知道怎么感谢你，非常激动，有这样一个好论坛，好伙伴们。方便留下一个qq，给你发个红包。谢谢谢谢谢谢谢谢谢谢

jiaxinl · 发表于 2017-8-13 10:51

救赎0003 发表于 2017-8-13 10:13
我不知道怎么感谢你，非常激动，有这样一个好论坛，好伙伴们。方便留下一个qq，给你发个红包。谢谢谢谢谢 ...

微信号：13790150245

autumnalRain · 发表于 2017-8-13 11:04

jiaxinl 发表于 2017-8-13 09:13
从Word中提取数据到Excel中---请看动态图及附件
代码如下：
Sub 从Word中提取数据到Excel中()

学习了，WORD没研究过，这个例子也很有用。

lcjy11185 · 发表于 2017-8-13 14:33

word表到Excel表不难

救赎0003 · 发表于 2017-8-13 16:01

lcjy11185 发表于 2017-8-13 14:33
word表到Excel表不难

http://club.excelhome.net/thread-1362664-1-1.html 这个用正则表达式很难的

jiaxinl · 发表于 2017-8-13 16:41

救赎0003 发表于 2017-8-13 16:01
http://club.excelhome.net/thread-1362664-1-1.html 这个用正则表达式很难的

问题已解决——请看以下黄底红字部分
代码如下：
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

For j = 5 + k1 + 3 To .Rows.Count  ''在第1个表格中从第5+k1+3行到总行数中循环
   If WorksheetFunction.Clean(.cell(j, 1).Range.Text) = "收货人" Then  '第1个收货人
      Exit For
   Else
      If WorksheetFunction.Clean(.cell(j, 1).Range.Text) <> "" Then k2 = k2 + 1 ''得到第2个型号的个数
   End If
Next j
If k1 > 0 Or k2 > 0 Then '型号的个数不等于0
      ReDim arr(1 To k1 + k2, 1 To 10) '重新定义数组arr
      If k1 > 0 Then '第1个型号的个数大于0
      arr(1, 1) = WorksheetFunction.Clean(.cell(1, 4).Range.Text) '合同号
      arr(1, 2) = WorksheetFunction.Clean(.cell(2, 2).Range.Text) '工程名称
      arr(1, 3) = WorksheetFunction.Clean(.cell(2, 4).Range.Text) '销售单号
      arr(1, 4) = WorksheetFunction.Clean(.cell(5, 2).Range.Text) '型号
      arr(1, 5) = WorksheetFunction.Clean(.cell(5, 3).Range.Text) '芯数
      arr(1, 6) = WorksheetFunction.Clean(.cell(5, 4).Range.Text) '数量
      arr(1, 7) = WorksheetFunction.Clean(.cell(5, 5).Range.Text) '盘长及盘数
      arr(1, 8) = WorksheetFunction.Clean(.cell(3, 2).Range.Text) '交货地址1
      arr(1, 9) = WorksheetFunction.Clean(.cell(5 + k1, 2).Range.Text) '收货人1
      arr(1, 10) = WorksheetFunction.Clean(.cell(5 + k1, 4).Range.Text) '联系电话1
      End If

      If k1 > 1 Then '第1个型号的个数大于1
      For r = 1 To k1 - 1  '提取第1个型号之后的
         arr(r + 1, 4) = WorksheetFunction.Clean(.cell(5 + r, 2).Range.Text) '型号
         arr(r + 1, 5) = WorksheetFunction.Clean(.cell(5 + r, 3).Range.Text) '芯数
         arr(r + 1, 6) = WorksheetFunction.Clean(.cell(5 + r, 4).Range.Text) '数量
         arr(r + 1, 7) = WorksheetFunction.Clean(.cell(5 + r, 5).Range.Text) '盘长及盘数
      Next r
      End If

      If k2 > 0 Then '第2个型号的个数大于0
      arr(k1 + 1, 4) = WorksheetFunction.Clean(.cell(5 + k1 + 3, 2).Range.Text) '型号
      arr(k1 + 1, 5) = WorksheetFunction.Clean(.cell(5 + k1 + 3, 3).Range.Text) '芯数
      arr(k1 + 1, 6) = WorksheetFunction.Clean(.cell(5 + k1 + 3, 4).Range.Text) '数量
      arr(k1 + 1, 7) = WorksheetFunction.Clean(.cell(5 + k1 + 3, 5).Range.Text) '盘长及盘数
      arr(k1 + 1, 8) = WorksheetFunction.Clean(.cell(5 + k1 + 1, 2).Range.Text) '交货地址2
      arr(k1 + 1, 9) = WorksheetFunction.Clean(.cell(.Rows.Count, 2).Range.Text) '收货人2
      arr(k1 + 1, 10) = WorksheetFunction.Clean(.cell(.Rows.Count, 4).Range.Text) '联系电话2
      End If

      If k2 > 1 Then  '第2个型号的个数大于1
      For rr = 1 To k2 - 1 ''提取第1个型号之后的
      arr(k1 + 1 + rr, 4) = WorksheetFunction.Clean(.cell(5 + k1 + 3 + rr, 2).Range.Text) '型号
      arr(k1 + 1 + rr, 5) = WorksheetFunction.Clean(.cell(5 + k1 + 3 + rr, 3).Range.Text) '芯数
      arr(k1 + 1 + rr, 6) = WorksheetFunction.Clean(.cell(5 + k1 + 3 + rr, 4).Range.Text) '数量
      arr(k1 + 1 + rr, 7) = WorksheetFunction.Clean(.cell(5 + k1 + 3 + rr, 5).Range.Text) '盘长及盘数
      Next rr
      End If
   End If
End With
Range("A" & Cells(Rows.Count, 4).End(3).Row + 1).Resize(k1 + k2, 10) = arr '把提取的内容赋值给Excel工作表
Erase arr  '重新初始化arr数组
k1 = 0: k2 = 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

		自动登录	找回密码
密码			免费注册

excel 如何自动提取多个word中固定位置的内容

评分