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

kuangben8

各位老师好：

         在该工作表里A:F列的数据均是来源于word版本的配方单里表格的数据。

         如左图所示，A列的月份来源于word里表格右下角的日期。

         B列的订单编号来源于word里表格第1行第4列的数据。

         C列的客户牌号来源于word里表格第1行第6列的数据。

         D、E、F三列的数据来源于word里表格第4行至第18行的3列数据。

         现在word格式的文件太多！想要通过VBA自动将各个文件夹里的所有word格式的数据全部汇总在excel表里，

因此请求各位老师的帮助！万分感谢！！(订单编号的文件夹会不断的增加，是否可以自动将已经添加过的文件夹过滤掉)

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

2017-9-12 11:16 上传

点击文件名下载附件

duquancai

绝对的苦命活！

kuangben8

duquancai 发表于 2017-9-12 11:34
绝对的苦命活！

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

duquancai

kuangben8 发表于 2017-9-12 12:11
对于目前的我来说是绝对的苦命活啊！所以恳请老师出手相助。

对于任何人都是苦命活！

kuangben8

duquancai 发表于 2017-9-12 13:03
对于任何人都是苦命活！

这么说这个问题的编程也是件苦命活了！哎。。。。

kuangben8

真的没有大神出手相助吗？

kuangben8

看来只有要求领导不要使用word格式的文件才是正道了！

jiaxinl

kuangben8 发表于 2017-9-13 09:19
看来只有要求领导不要使用word格式的文件才是正道了！

下午有空的时候帮你做

jiaxinl

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

kuangben8

jiaxinl 发表于 2017-9-13 15:40
请查收动态图及附件
WordtoExcel代码如下：
Dim brr(), sfolder$, x&  '公共变量

感谢老师的热心帮忙！谢谢！写代码不像写函数公式，几分钟就可以搞定的事情。写代码花费的时间要多很多！再次感谢老师的无私帮助！谢谢！！