VBA 对多个区域内的数据汇总到一新工作表

jia1986

各位Excel老师：
求助……  如图，
由“日历数据”→“汇总数据”的汇总，能否用VBA实现呢？
怎么编写VBA呢？？
谢谢！！！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, zrr()
   
4.   With Worksheets("201808")
   
5.     r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
6.     c = .Cells(3, .Columns.Count).End(xlToLeft).Column
   
7.     arr = .Range("a1").Resize(r, c)
   
8.     m = 0
   
9.     For i = 1 To UBound(arr)
   
10.       If arr(i, 1) = "编号" Then
    
11.         m = m + 1
    
12.         ReDim Preserve zrr(1 To 2, 1 To m)
    
13.         zrr(1, m) = i
    
14.         zrr(2, m) = i
    
15.       Else
    
16.         If m <> 0 Then
    
17.           zrr(2, m) = i
    
18.         End If
    
19.       End If
    
20.     Next
    
21.     ReDim brr(1 To UBound(arr, 2) / 4 * UBound(arr), 1 To 3)
    
22.     m = 0
    
23.     For k = 1 To UBound(zrr, 2)
    
24.       For i = zrr(1, k) + 1 To zrr(2, k) - 1
    
25.         For j = 1 To UBound(arr, 2) Step 4
    
26.           If Len(arr(i, j)) <> 0 Then
    
27.             m = m + 1
    
28.             brr(m, 1) = arr(i, j)
    
29.             brr(m, 2) = arr(i, j + 1)
    
30.             brr(m, 3) = arr(i, j + 2)
    
31.           End If
    
32.         Next
    
33.       Next
    
34.     Next
    
35.             
    
36.   End With
    
37.   With Worksheets("sheet2")
    
38.     .Range("a2").Resize(m, UBound(brr, 2)) = brr
    
39.   End With
    
40.   
    
41. End Sub
    

复制代码

chxw68

详见附件。

jia1986

chxw68 发表于 2018-8-23 09:26
详见附件。

感谢老师的回复，基本功能实现了，谢谢

请问老师：
汇总的表数据能按日期下面的编号内容排序么？比如：从1号到31号，1号下面的数据汇总完再汇总2号下面的的，以此类推直至31号啊后一个结束。