ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! 国内首部Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 187|回复: 9
打印 上一主题 下一主题

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

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2017-8-12 20:19 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
本帖最后由 救赎0003 于 2017-8-12 22:31 编辑

合同号
工程名称
销售单号
规格
芯数
数量(KM)
盘数
交货地址
收货人
联系电话


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

按照大师们写的VBA 我自己改了,运行出现的问题,我应该怎么修改。
微信截图_20170812202007.png (20.81 KB, 下载次数: 1)
微信截图_20170812202007.png
bva问题.png (37.62 KB, 下载次数: 0)
bva问题.png
提问1.rar 28.48 KB, 下载次数: 7 提问附件
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏3 分享分享 有用有用 无用无用
TA的精华主题TA的得分主题
2
发表于 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


从Word中提取数据到Excel中.gif (611.13 KB, 下载次数: 2)
从Word中提取数据到Excel中.gif
从Word中提取数据到Excel中.zip 48.11 KB, 下载次数: 18

评分

参与人数 1鲜花 +3 收起 理由
autumnalRain + 3 优秀作品
查看全部评分
TA的精华主题TA的得分主题
3
发表于 2017-8-13 09:35 | 只看该作者
你得说明一下,WORD中的序号是不是都是两个......................................................................
TA的精华主题TA的得分主题
4
 楼主| 发表于 2017-8-13 10:10 | 只看该作者 |楼主
小花鹿 发表于 2017-8-13 09:35
你得说明一下,WORD中的序号是不是都是两个............................................................ ...

有时候是3个序号,型号下  有多少提取多少。
TA的精华主题TA的得分主题
5
 楼主| 发表于 2017-8-13 10:13 | 只看该作者 |楼主
jiaxinl 发表于 2017-8-13 09:13
从Word中提取数据到Excel中---请看动态图及附件
代码如下:
Sub 从Word中提取数据到Excel中()

我不知道怎么感谢你,非常激动,有这样一个好论坛,好伙伴们。方便留下一个qq,给你发个红包。谢谢谢谢谢谢谢谢谢谢
TA的精华主题TA的得分主题
6
发表于 2017-8-13 10:51 来自手机 | 只看该作者
救赎0003 发表于 2017-8-13 10:13
我不知道怎么感谢你,非常激动,有这样一个好论坛,好伙伴们。方便留下一个qq,给你发个红包。谢谢谢谢谢 ...

微信号:13790150245
TA的精华主题TA的得分主题
7
发表于 2017-8-13 11:04 | 只看该作者
jiaxinl 发表于 2017-8-13 09:13
从Word中提取数据到Excel中---请看动态图及附件
代码如下:
Sub 从Word中提取数据到Excel中()

学习了,WORD没研究过,这个例子也很有用。
TA的精华主题TA的得分主题
8
发表于 2017-8-13 14:33 | 只看该作者
TA的精华主题TA的得分主题
9
 楼主| 发表于 2017-8-13 16:01 | 只看该作者 |楼主
TA的精华主题TA的得分主题
10
发表于 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


发货计划_新.zip 29.34 KB, 下载次数: 4
您需要登录后才可以回帖 登录 | 免费注册
本版积分规则
关闭

最新热点上一条 /1 下一条

关注官方微信,每天坐享新鲜教程
手机版|关于我们|联系我们|ExcelHome    GMT+8, 2017-12-12 02:46 , Processed in 1.141845 second(s), 29 queries , Gzip On.
Powered by Discuz! X3.3 © 2001-2017 Wooffice Inc.
    沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
快速回复 返回顶部 返回列表
99uu优优