ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 挑战你的Excel知识,一起测验下 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 2716|回复: 15

[求助] 关于遍历文件夹获取数据汇总的求助帖

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-9-12 11:18 | 显示全部楼层 |阅读模式
本帖最后由 kuangben8 于 2017-9-12 11:20 编辑

各位老师好:
         在该工作表里A:F列的数据均是来源于word版本的配方单里表格的数据。
         如左图所示,A列月份来源于word里表格右下角的日期
         B列订单编号来源于word里表格第1行第4列的数据。
         C列客户牌号来源于word里表格第1行第6列的数据。
         D、E、F三列的数据来源于word里表格第4行至第18行的3列数据。

         现在word格式的文件太多!想要通过VBA自动将各个文件夹里的所有word格式的数据全部汇总在excel表里,
因此请求各位老师的帮助!万分感谢!!(订单编号的文件夹会不断的增加,是否可以自动将已经添加过的文件夹过滤掉)

求助.jpg

配方汇总.zip (304.26 KB, 下载次数: 53)

TA的精华主题

TA的得分主题

发表于 2017-9-12 11:34 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-9-12 12:11 | 显示全部楼层

对于目前的我来说是绝对的苦命活啊!所以恳请老师出手相助。

TA的精华主题

TA的得分主题

发表于 2017-9-12 13:03 来自手机 | 显示全部楼层
kuangben8 发表于 2017-9-12 12:11
对于目前的我来说是绝对的苦命活啊!所以恳请老师出手相助。

对于任何人都是苦命活!

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-9-12 15:11 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-9-12 21:43 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-9-13 09:19 | 显示全部楼层
看来只有要求领导不要使用word格式的文件才是正道了!

TA的精华主题

TA的得分主题

发表于 2017-9-13 12:07 来自手机 | 显示全部楼层
kuangben8 发表于 2017-9-13 09:19
看来只有要求领导不要使用word格式的文件才是正道了!

下午有空的时候帮你做

评分

参与人数 1鲜花 +3 收起 理由
kuangben8 + 3 值得肯定

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-9-13 15:40 | 显示全部楼层
kuangben8 发表于 2017-9-13 09:19
看来只有要求领导不要使用word格式的文件才是正道了!

请查收动态图及附件
WordtoExcel代码如下:
Dim brr(), sfolder$, x&  '公共变量

Sub WordtoExcel批量提取()
Dim FSO, arr, StarTime As Date, EndTime As Date
StarTime = Timer  '开始时间
Application.ScreenUpdating = False
Call 递归(ThisWorkbook.Path) '遍历当前文件夹及所有子文件夹下的文件
With Sheet3  '工作表【配方汇总新】
  .[A2].Resize(UBound(brr, 2), 6) = Application.Transpose(brr) '数组赋值给工作表中的E列
  With .Range("A2:F" & UBound(brr, 2) + 1) '设定格式
      .Font.Size = 10: .Borders.Value = 1
      .HorizontalAlignment = xlCenter
      .VerticalAlignment = xlCenter
  End With
  .Columns("A:F").EntireColumn.AutoFit '自动适合栏宽
End With
Application.ScreenUpdating = True
EndTime = Timer '结束时间
MsgBox "从Word中批量提取数据已完成!" & Chr(13) & Format(EndTime - StarTime, "程序运行时间约为:0.00秒"), 64, "提取结果"
End Sub

Sub 递归(ByVal pth) '递归  遍历当前文件夹及所有子文件夹下的文件
'意思是:总结算法规律,通过对自身的反复调用进行深化或遍历处理。
'可以大大缩减代码语句的数量。(相同的算法不用重复写代码了。)
  Dim FSO, f, ff, fd, kk, 文件路径$
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Set f = FSO.GetFolder(pth)  '获取文件夹的路径

  ff = Dir(f & "\*.doc*") '循环查找Word,可以适应不同版本 '具体提取哪类文件,还是需要根据文件扩展名进行处理
  Do While ff <> ""  '在目录中循环
    文件路径 = f & "\" & ff
    Call 从Word中提取数据到Excel中(文件路径)  '文件路径
    ff = Dir
  Loop '结束循环
  For Each fd In f.subfolders  '子文件夹中遍历
   If fd <> sfolder Then 递归 (fd) '子文件夹不是“提取文件”时,进行递归
  Next fd
End Sub

Sub 从Word中提取数据到Excel中(文件路径$)
  Dim WrdDocApp As Object, wordFilePath$, i As Byte, k As Byte, j As Byte
  Application.ScreenUpdating = False

  Set WrdDocApp = CreateObject("Word.Application")    '用Set关键词创建Word应用程序对象!
  wordFilePath = 文件路径 '文件的路径
  On Error Resume Next
  Set WrdDoc = GetObject(wordFilePath) '使用此代码 ,打开Word文件 视窗会自动隐藏(给人的感觉是没有打开做的操作)

  With WrdDoc.Tables(1) '提取Word文件内每1页的第1个表格内容
    For i = 4 To .Rows.Count - 3
      If WorksheetFunction.Clean(.cell(i, 1).Range.Text) <> "" Then k = k + 1
    Next i
  End With
  If UBound(brr, 2) = "" Then
    x = x + k
  Else
    x = x + UBound(brr, 2) + k
  End If
  jj = jj + UBound(brr, 2)
  ReDim Preserve brr(1 To 6, 1 To x) '重新定义数组
    With WrdDoc.Tables(1) '提取Word文件内每1页的第1个表格内容
      For j = 1 To k
        brr(1, jj + j) = WorksheetFunction.Clean(.cell(.Rows.Count, 6).Range.Text) '表格的最后1行第6列的单元格清除不可见字符后的内容赋值给数组
        brr(2, jj + j) = WorksheetFunction.Clean(.cell(1, 4).Range.Text)
        brr(3, jj + j) = WorksheetFunction.Clean(.cell(1, 6).Range.Text)
        brr(4, jj + j) = WorksheetFunction.Clean(.cell(j + 3, 1).Range.Text)
        brr(5, jj + j) = WorksheetFunction.Clean(.cell(j + 3, 2).Range.Text)
        brr(6, jj + j) = WorksheetFunction.Clean(.cell(j + 3, 3).Range.Text)
      Next j
    End With
  WrdDocApp.Quit  '关闭Word程序
  Set WrdDocApp = Nothing
  Application.ScreenUpdating = True
End Sub

WordtoExcel.gif

配方汇总.zip

327.43 KB, 下载次数: 130

评分

参与人数 1鲜花 +3 收起 理由
kuangben8 + 3 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-9-13 21:30 | 显示全部楼层
jiaxinl 发表于 2017-9-13 15:40
请查收动态图及附件
WordtoExcel代码如下:
Dim brr(), sfolder$, x&  '公共变量

感谢老师的热心帮忙!谢谢!写代码不像写函数公式,几分钟就可以搞定的事情。写代码花费的时间要多很多!再次感谢老师的无私帮助!谢谢!!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2019-9-19 14:15 , Processed in 0.067796 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表