数据存储及分类汇总

qjy321

向褚老师求助个问题，用VBA来实现。

lsc900707

既然向褚老师请教，就向他发信息，否则他很难看到你的需求！

qjy321

lsc900707 发表于 2018-9-21 20:58
既然向褚老师请教，就向他发信息，否则他很难看到你的需求！

您也可以呀。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("收费单据")
   
7.     ReDim brr(1 To 7)
   
8.     brr(1) = .Range("f3")
   
9.     brr(2) = .Range("b3")
   
10.     brr(3) = .Range("b4")
    
11.     brr(4) = .Range("b5")
    
12.     brr(5) = .Range("d5")
    
13.     brr(6) = .Range("f5")
    
14.     brr(7) = .Range("d4")
    
15.     .PrintOut
    
16.     .Range("f3") = Format(Val(.Range("f3")) + 1, "0000")
    
17.     .Range("b3:b5,d4") = ""
    
18.   End With
    
19.   With Worksheets("收费明细")
    
20.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.     If r = 1 Then
    
22.       m = 2
    
23.     Else
    
24.       For i = 2 To r
    
25.         If .Cells(i, 1) = brr(1) Then
    
26.           Exit For
    
27.         End If
    
28.       Next
    
29.       If i <= r Then
    
30.         m = i
    
31.       Else
    
32.         m = r + 1
    
33.       End If
    
34.     End If
    
35.     .Cells(m, 1).Resize(1, UBound(brr)) = brr
    
36.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
37.     arr = .Range("a2:g" & r)
    
38.   End With
    
39.   For i = 1 To UBound(arr)
    
40.     If InStr(arr(i, 7), "小区") <> 0 Then
    
41.       xm = Split(arr(i, 7), "小区")(0) & "小区"
    
42.       If Not d.exists(xm) Then
    
43.         ReDim brr(1 To 7)
    
44.         brr(1) = xm
    
45.       Else
    
46.         brr = d(xm)
    
47.       End If
    
48.       If arr(i, 2) = Date Then
    
49.         brr(2) = brr(2) + 1
    
50.         brr(3) = brr(3) + arr(i, 4)
    
51.         brr(4) = brr(4) + arr(i, 6)
    
52.       End If
    
53.       brr(5) = brr(5) + 1
    
54.       brr(6) = brr(6) + arr(i, 4)
    
55.       brr(7) = brr(7) + arr(i, 6)
    
56.       d(xm) = brr
    
57.     End If
    
58.   Next
    
59.   With Worksheets("汇总统计")
    
60.     .Range("a4:g13").ClearContents
    
61.     .Range("a4").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
62.   End With
    
63. End Sub
    

复制代码

chxw68

详见附件。

qjy321

chxw68 发表于 2018-9-23 09:02
详见附件。

谢谢老师，非常完美！