分表数据自动分类汇总到总表

WUHANWBS

各位大神们，紧急求助：分表数据自动分类汇总到总表，见附件！

ykcbf1100

你这个统计表设计得有问题的，如果仅按周统计没问题，但是按月、季、年统计时就有问题了，因为周有可能跨越月份，跨越季度、跨越年度。这个是无法统计的。你这分表的表名不会就是月份吧。请再说明一下。
另外，你这分表中居然没数据，这个写好代码也没法调试啊。请给分表中输入一定数据再重新上传吧。

WUHANWBS

谢谢，已修改！

ykcbf1100

WUHANWBS 发表于 2024-7-30 16:30
谢谢，已修改！

周统计是只统计一个周还是统计出所有周数据？月数据同问。

WUHANWBS

感谢！统计本周的。

WUHANWBS

月度，也是当前月，与周一样。

WUHANWBS

月度的也一样，统计当前月度的数据。

心的启点

你这汇总表里只有周月年汇总，季度呢？还有周汇总是汇总第几周的呢？月汇总又是哪个月的？

ykcbf1100

WUHANWBS 发表于 2024-7-30 17:12
月度的也一样，统计当前月度的数据。

还是有点麻烦的，周、月、年度要分别统计的。

本周无数据，结果请自行验证。

ykcbf1100

分周期统计

1. Sub ykcbf()   '//2024.7.31   周、月、年统计
   
2.     Dim rq As Date
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("汇总分析")
   
6.     rq = Date
   
7.     yf = DatePart("m", rq)
   
8.     nf = DatePart("yyyy", rq)
   
9.     zz = DatePart("ww", rq)
   
10.     b = [{6,14,22,30,38}]
    
11.     fn = [{"应收","实收"}]
    
12.     ReDim brr(1 To 1000, 1 To 1)
    
13.     On Error Resume Next
    
14.     For Each sht In Sheets
    
15.         If Val(sht.Name) Then
    
16.             With sht
    
17.                 r = .UsedRange.Find("合计：").Row
    
18.                 c = .UsedRange.Columns.Count
    
19.                 arr = .[a1].Resize(r - 1, c)
    
20.                 For x = 1 To UBound(b)
    
21.                     If Val(.Cells(3, b(x))) = zz Then jj = j
    
22.                 Next
    
23.             End With
    
24.             For i = 6 To UBound(arr)
    
25.                 s = arr(i, 1)
    
26.                 If Not d.exists(s) Then
    
27.                     m = m + 1
    
28.                     d(s) = m
    
29.                     brr(m, 1) = s
    
30.                 End If
    
31.                 For j = UBound(arr, 2) - 1 To UBound(arr, 2)
    
32.                     s = arr(i, 1) & "|" & arr(5, j) & "|" & nf
    
33.                     d(s) = d(s) + arr(i, j)
    
34.                 Next
    
35.                 If sht.Name = CStr(yf) Then
    
36.                     For j = UBound(arr, 2) - 1 To UBound(arr, 2)
    
37.                         s = arr(i, 1) & "|" & arr(5, j) & "|" & yf
    
38.                         d(s) = d(s) + arr(i, j)
    
39.                     Next
    
40.                 End If
    
41.                 If sht.Name = CStr(yf) And jj > 0 Then
    
42.                     For y = 1 To 2
    
43.                         s = arr(i, 1) & "|" & fn(y)
    
44.                         d(s) = d(s) + arr(i, jj - 5 + y) + arr(i, jj - 3 + y) + arr(i, jj - 1 + y) + arr(i, jj + 1 + y)
    
45.                     Next
    
46.                 End If
    
47.             Next
    
48.         End If
    
49.     Next
    
50.     With sh
    
51.         .[b3] = "第" & zz & "周销售额"
    
52.         .[d3] = yf & "月销售额"
    
53.         .[f3] = nf & "年度销售额"
    
54.         .[a5].Resize(12, 7).ClearContents
    
55.         If m > 12 Then
    
56.             For i = 1 To m - 12
    
57.                 Cells(5 + i, 1).EntireRow.Insert
    
58.             Next i
    
59.         End If
    
60.         .[a5].Resize(m, 1) = brr
    
61.         arr = .[a3].Resize(m + 2, 7)
    
62.         For i = 3 To UBound(arr)
    
63.             For j = 2 To 3
    
64.                 s = arr(i, 1) & "|" & arr(2, j)
    
65.                 If d.exists(s) Then
    
66.                     arr(i, j) = d(s)
    
67.                 End If
    
68.             Next
    
69.             For j = 4 To 5
    
70.                 s = arr(i, 1) & "|" & arr(2, j) & "|" & yf
    
71.                 If d.exists(s) Then
    
72.                     arr(i, j) = d(s)
    
73.                 End If
    
74.             Next
    
75.             For j = 6 To 7
    
76.                 s = arr(i, 1) & "|" & arr(2, j) & "|" & nf
    
77.                 If d.exists(s) Then
    
78.                     arr(i, j) = d(s)
    
79.                 End If
    
80.             Next
    
81.         Next
    
82.         .[a3].Resize(m + 2, 7) = arr
    
83.     End With
    
84.     Set d = Nothing
    
85.     Application.ScreenUpdating = True
    
86.     MsgBox "OK！"
    
87. End Sub
    

复制代码