按月汇总

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

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