按月汇总

Qs18

1. Sub qs()
   
2. Dim arr, i, dic, sht As Worksheet
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. ReDim brr(1 To 1000, 1 To 100): brr(1, 1) = "NO"
   
5. m = 1: c = 1
   
6. For Each sht In Sheets
   
7.     If sht.Name <> "汇总" Then
   
8.         rw = sht.Cells(Rows.Count, "j").End(3).Row
   
9.         arr = sht.Range("g3:j" & rw).Value
   
10.             For i = 1 To UBound(arr)
    
11.                 If arr(i, 3) <> Empty And arr(i, 4) <> Empty Then
    
12.                     xm = arr(i, 4)
    
13.                     dt = CDate(arr(i, 3))
    
14.                     dt = "'" & Year(dt) & "年" & Month(dt) & "月"
    
15.                     If Not dic.exists(dt) Then
    
16.                         m = m + 1
    
17.                         dic(dt) = m
    
18.                         brr(m, 1) = dt
    
19.                     End If
    
20.                     
    
21.                     If Not dic.exists(xm) Then
    
22.                         c = c + 1
    
23.                         dic(xm) = c
    
24.                         brr(1, c) = xm
    
25.                     End If
    
26.                     rw = dic(dt): cl = dic(xm)
    
27.                     brr(rw, cl) = brr(rw, cl) + Val(arr(i, 1))
    
28.                
    
29.                 End If
    
30.             Next i
    
31.     End If
    
32. Next
    
33.     ReDim crr(1 To 1, 1 To c + 1)
    
34.     crr(1, 1) = "合计"
    
35.     For j = 2 To c
    
36.         crr(1, j) = Application.Sum(Application.Index(brr, 0, j))
    
37.     Next
    
38.     ReDim drr(1 To m, 1 To 1): drr(1, 1) = "小计"
    
39.     sm = 0
    
40.     For i = 2 To m
    
41.         drr(i, 1) = Application.Sum(Application.Index(brr, i, 0))
    
42.         sm = sm + drr(i, 1)
    
43.     Next
    
44.         crr(1, c + 1) = sm
    
45. With Sheet1
    
46.     .[a3].Resize(m, c) = brr
    
47.     .[a3].Offset(m, 0).Resize(1, c + 1) = crr
    
48.     .[a3].Offset(0, c).Resize(m, 1) = drr
    
49. End With
    
50. End Sub
    

复制代码

Qs18

试试..........

Qs18

试试............

hyhsql

Qs18 发表于 2024-10-31 20:24
试试............

Qs18老师，有个问题就是一但增加项目就不统计了，能不能改一下代码。

Qs18

把增加项目就不统计了的附件发来，看看呢

Qs18

hyhsql 发表于 2024-11-6 09:35
Qs18老师，有个问题就是一但增加项目就不统计了，能不能改一下代码。

或者其他老师的没有问题，用其他老师的也一样的

hyhsql

QS18l老师主要是学习一下代码，附件已上传

hyhsql

ykcbf1100 发表于 2024-10-31 16:39
参与一下，全表自动生成

ykcbf1100老师，能不能给看一下附件，你的代码当数据多时就不能正常按月排序和汇总了

ykcbf1100

hyhsql 发表于 2024-11-14 18:21
ykcbf1100老师，能不能给看一下附件，你的代码当数据多时就不能正常按月排序和汇总了

原代码并没有排序功能。

附件中已加入排序功能。。。

Qs18

hyhsql 发表于 2024-11-6 15:52
QS18l老师主要是学习一下代码，附件已上传

你的数据表的名称和项目的名称不一样，是按表的项目名称统计的