VBA获取月份数据源合并到一个工作表

杨大敏

因为工作需要，这里有个每天更新的数据源工作薄，需要自己定义一个工作薄来合并需要的月份数据源。

要求说明：
1.故障清单文件夹：里面都是每天的数据源，都是每天自动出现新的日期数据源，假如今天2024年1月19日就会出现一个新的2024年1月18日数据源在故障清单文件夹里。



按钮要求：
1.按照“汇总表”的G1单元格日期，根据日期获取“故障清单文件夹”里面的对应日期数据源，获取整月份的数据源，比如1号到18号的日期数据源。

2.根据“汇总表”的工单列表“标题”，将数据源的内容全部合并到，这里的工单列表里。标题对应的获取，标题不对应的不获取。

以上内容简易说明就是将整月的数据源合并到汇总表的工单列表里面，有日期和标题要求。


麻烦做好的老师帮忙答复一下附件，程序代码填写下注释，非常感谢。

可以把“汇总表”改为启用宏的工作薄。

ykcbf1100

[h1]单元格指定路径

shiruiqiang

建议添加个工作簿的名称。
选择文件夹，汇总

杨大敏

shiruiqiang 发表于 2024-1-20 08:43
建议添加个工作簿的名称。
选择文件夹，汇总

老师你好，你的附件下载后0KB，打不开压缩包文件，需要麻烦再上传一次。

gwjkkkkk

论坛下载压缩包都打不开。。。

杨大敏

gwjkkkkk 发表于 2024-1-20 13:54
论坛下载压缩包都打不开。。。

请问如何才能得到老师的附件

ykcbf1100

最近论坛总是出问题，前段时间开始Edge浏览器打开论坛后总是无法下载，现在换成谷歌浏览器下载附件也无法解压缩了。希望论坛想想办法，去解决这个问题。

杨大敏

更换了WIN10浏览器下载附件也打不开，发现以前的附件下载也不开附件。

麻烦帮忙的老师给我VBA代码吧，我自己插入模块用按钮执行代码运行。

ykcbf1100

杨大敏 发表于 2024-1-20 13:57
请问如何才能得到老师的附件

你重新上传一下附件，我在其它帖子上又能下载的。

shiruiqiang

Sub test()
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Dim arr, brr(1 To 1000000, 1 To 40)

  Set fso = CreateObject("scripting.filesystemobject")
  rq = Format(Sheets(2).[g1], "yyyymm")
  With Application.FileDialog(msoFileDialogFolderPicker)
  .InitialFileName = ThisWorkbook.Path & "\"
  .Title = "请选择对应文件夹"
  .AllowMultiSelect = False
  If .Show Then
    fd = .SelectedItems(1)
  Else
    MsgBox "未选择有效文件夹路径", vbCritical, "警告"
    End
  End If
  End With


  For Each f In fso.getfolder(fd).Files
  If InStr(f.Name, rq) Then
  With Workbooks.Open(f)
    arr = .Sheets(1).UsedRange
    For x = 2 To UBound(arr)
      If Len(arr(x, 1) & arr(x, 2)) Then
      n = n + 1
      brr(n, 1) = Split(f.Name, ".")(0)
      For y = 1 To UBound(arr, 2)
      brr(n, y + 1) = arr(x, y)
      Next
      End If
    Next
    .Close False
  End With
  End If
  Next f

  Sheets("工单列表").[a2:an1000000].ClearContents
  If n > 0 Then
  Sheets("工单列表").[a2].Resize(n, 40) = brr
  MsgBox "已提取到" & n & "条数据！"
  Else
  MsgBox "未提取到数据，请核对日期!"
  End If
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

shiruiqiang

杨大敏 发表于 2024-1-20 13:37
老师你好，你的附件下载后0KB，打不开压缩包文件，需要麻烦再上传一次。

等审核