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

ykcbf1100

代码更新如下：

1. Sub ykcbf()  '//2024.2.29
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim arr, brr(1 To 100000, 1 To 100), d
   
5.     Dim tm: tm = Timer
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     Set sh = ThisWorkbook.Sheets("工单列表")
   
9.     yf = Format(ThisWorkbook.Sheets("汇总").[g1], "yyyymm")  '//条件1:按年+月汇总
   
10.     nf = Val(ThisWorkbook.Sheets("汇总").[g2])               '//条件2:按全年汇总
    
11.     With sh
    
12.         c = .UsedRange.Columns.Count
    
13.         For j = 2 To c + 1
    
14.             n = n + 1
    
15.             s = .Cells(1, j)
    
16.             d(s) = n
    
17.         Next
    
18.     End With
    
19.     st2 = Val(Application.InputBox("请选择汇总方式：1、按年月汇总，2、按全年汇总", "输入数字", 1, , , , , 1))
    
20.     '//文件夹动态选择
    
21.     With Application.FileDialog(msoFileDialogFolderPicker)
    
22.         .Title = "请选择文件夹"
    
23.         .InitialFileName = ThisWorkbook.Path & ""
    
24.         If .Show = -1 Then
    
25.             p = .SelectedItems(1) & ""
    
26.         End If
    
27.     End With
    
28. 
    
29.     ' p = "D:\重要文件\Desktop\新建文件夹\故障汇报\故障清单"    '//指定文件夹
    
30.     On Error Resume Next
    
31.     For Each f In fso.GetFolder(p).Files
    
32.         If f.Name Like "*.xls*" Then
    
33.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
34.                 fn = fso.GetBaseName(f)
    
35.                 Select Case st2
    
36.                     Case Is = 1
    
37.                         rq = Left(Replace(fn, "故障清单", ""), 6)
    
38.                         日期条件 = yf
    
39.                     Case Is = 2
    
40.                         rq = Val(Mid(fn, 5, 4))
    
41.                         日期条件 = nf
    
42.                 End Select
    
43.                 If rq = 日期条件 Then
    
44.                     Set wb = Workbooks.Open(f, 0)
    
45.                     With wb.Sheets(1)
    
46.                         arr = .UsedRange
    
47.                         wb.Close False
    
48.                     End With
    
49.                     For i = 2 To UBound(arr)
    
50.                         If arr(i, 1) <> Empty Then
    
51.                             m = m + 1
    
52.                             For j = 1 To UBound(arr, 2)
    
53.                                 s = arr(1, j)
    
54.                                 If d.exists(s) Then
    
55.                                     brr(m, d(s)) = arr(i, j)
    
56.                                 End If
    
57.                             Next
    
58.                         End If
    
59.                     Next
    
60.                 End If
    
61.             End If
    
62.         End If
    
63.     Next f
    
64.     With sh
    
65.         .UsedRange.Offset(1).Clear
    
66.         With .[b2].Resize(m, n)
    
67.             .Value = brr
    
68.             .Borders.LineStyle = 1
    
69.             .HorizontalAlignment = xlCenter
    
70.             .VerticalAlignment = xlCenter
    
71.         End With
    
72.     End With
    
73.     Set d = Nothing
    
74.     Application.ScreenUpdating = True
    
75.     MsgBox "共用时：" & Format(Timer - tm) & "秒！"
    
76. End Sub
    

复制代码

杨大敏

fzxba 发表于 2024-2-29 13:41

谢谢老师帮忙，太强大了，还做出了我没有想到的功能，比如时间段的获取，除此之外还保留了路径单元格H1选择，非常感谢。

杨大敏

ykcbf1100 发表于 2024-2-29 13:49
代码已更新，即可以按年+月汇总，也可以按全年汇总。开始时选择汇总方式，默认是按年+月汇总。文件夹路径 ...

非常感谢老师的答复，正常应该保留H1指定单元格，减少选择更加好，因为我们需要一键获取功能。

19楼老师已经详细解答了年、月、日、以及路径指定了，非常感谢您，后面有新要求再想您请教。