请教如何分物品得出累计数

kezhiye

     附件中点击“插入本月合计和本年累计”按钮，得出的本年累计是没有分物品的，比如大豆的本年累计包括了玉米，棉花的本年累计包括了玉米和大豆。

       请教如何分物品得出本年累计，即各种物品分别进行本年累计。

       大豆的第一个本年累计应为2，第二个本年累计应为6。棉花的第一个本年累计应为4，第二个本年累计应为6，棉花的第三个本年累计应为10。

    谢谢！

   如何分物品得出累计数.rar (24.04 KB, 下载次数: 11)

2018-9-5 11:07 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr(1 To 2, 13 To 16) As Double
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     For j = 13 To 16
   
9.       brr(1, j) = .Cells(2, j)
   
10.       brr(2, j) = .Cells(2, j)
    
11.     Next
    
12.     i = 3
    
13.     Do While .Cells(i, 8) <> ""
    
14.       If .Cells(i, 3) = .Cells(i - 1, 3) Then
    
15.         For j = 13 To 16
    
16.           brr(2, j) = brr(2, j) + .Cells(i, j)
    
17.         Next
    
18.         If .Cells(i, 8) = .Cells(i - 1, 8) Then
    
19.           For j = 13 To 16
    
20.             brr(1, j) = brr(1, j) + .Cells(i, j)
    
21.           Next
    
22.         Else
    
23.           .Rows(i).Insert shift:=xlDown
    
24.           .Cells(i, 8) = "本月合计"
    
25.           .Cells(i, 13).Resize(1, 4) = Application.Index(brr, 1, 0)
    
26.           For j = 13 To 16
    
27.             brr(1, j) = .Cells(i + 1, j)
    
28.           Next
    
29.           i = i + 1
    
30.         End If
    
31.       Else
    
32.         .Rows(i).Insert shift:=xlDown
    
33.         .Cells(i, 8) = "本月合计"
    
34.         .Cells(i, 13).Resize(1, 4) = Application.Index(brr, 1, 0)
    
35.         .Rows(i + 1).Insert shift:=xlDown
    
36.         .Cells(i + 1, 8) = "本年合计"
    
37.         .Cells(i + 1, 13).Resize(1, 4) = Application.Index(brr, 2, 0)
    
38.         For k = 1 To 2
    
39.           For j = 13 To 16
    
40.             brr(k, j) = .Cells(i + 2, j)
    
41.           Next
    
42.         Next
    
43.         i = i + 2
    
44.       End If
    
45.       i = i + 1
    
46.     Loop
    
47.     .Cells(i, 8) = "本月合计"
    
48.     .Cells(i, 13).Resize(1, 4) = Application.Index(brr, 1, 0)
    
49.     .Cells(i + 1, 8) = "本年合计"
    
50.     .Cells(i + 1, 13).Resize(1, 4) = Application.Index(brr, 2, 0)
    
51.   End With
    
52. End Sub
    

复制代码

chxw68

详见附件。

kezhiye

chxw68 发表于 2018-9-5 12:05
详见附件。

谢谢师傅这么快就帮我做出来了。
我测试了一下结果，你把各物品中间月份的本年累计去掉了，这样与要达到的效果有点区别。各物品各月份都要有本年累计就更好。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr(1 To 2, 13 To 16) As Double
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     For j = 13 To 16
   
9.       brr(1, j) = .Cells(2, j)
   
10.       brr(2, j) = .Cells(2, j)
    
11.     Next
    
12.     i = 3
    
13.     Do While .Cells(i, 8) <> ""
    
14.       If .Cells(i, 3) = .Cells(i - 1, 3) Then
    
15.         If .Cells(i, 8) = .Cells(i - 1, 8) Then
    
16.           For j = 13 To 16
    
17.             brr(1, j) = brr(1, j) + .Cells(i, j)
    
18.           Next
    
19.         Else
    
20.           .Rows(i).Insert shift:=xlDown
    
21.           .Cells(i, 8) = "本月合计"
    
22.           .Cells(i, 13).Resize(1, 4) = Application.Index(brr, 1, 0)
    
23.           .Rows(i + 1).Insert shift:=xlDown
    
24.           .Cells(i + 1, 8) = "本年累计"
    
25.           .Cells(i + 1, 13).Resize(1, 4) = Application.Index(brr, 2, 0)
    
26.           For j = 13 To 16
    
27.             brr(1, j) = .Cells(i + 2, j)
    
28.           Next
    
29.           i = i + 2
    
30.         End If
    
31.         For j = 13 To 16
    
32.           brr(2, j) = brr(2, j) + .Cells(i, j)
    
33.         Next
    
34.       Else
    
35.         .Rows(i).Insert shift:=xlDown
    
36.         .Cells(i, 8) = "本月合计"
    
37.         .Cells(i, 13).Resize(1, 4) = Application.Index(brr, 1, 0)
    
38.         .Rows(i + 1).Insert shift:=xlDown
    
39.         .Cells(i + 1, 8) = "本年累计"
    
40.         .Cells(i + 1, 13).Resize(1, 4) = Application.Index(brr, 2, 0)
    
41.         For k = 1 To 2
    
42.           For j = 13 To 16
    
43.             brr(k, j) = .Cells(i + 2, j)
    
44.           Next
    
45.         Next
    
46.         i = i + 2
    
47.       End If
    
48.       i = i + 1
    
49.     Loop
    
50.     .Cells(i, 8) = "本月合计"
    
51.     .Cells(i, 13).Resize(1, 4) = Application.Index(brr, 1, 0)
    
52.     .Cells(i + 1, 8) = "本年累计"
    
53.     .Cells(i + 1, 13).Resize(1, 4) = Application.Index(brr, 2, 0)
    
54.   End With
    
55. End Sub
    

复制代码

chxw68

详见附件。

kezhiye

chxw68 发表于 2018-9-5 12:46
详见附件。

这个正是想要的效果，感谢您多次热情的帮助

chxw68

1. Sub test3()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.     arr = .Range("a2:p" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Right(arr(i, 8), 1) <> "计" Then
    
11.         If Not d.exists(arr(i, 3)) Then
    
12.           Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
    
13.         End If
    
14.         If Not d(arr(i, 3)).exists(arr(i, 8)) Then
    
15.           m = 1
    
16.           ReDim brr(1 To UBound(arr, 2), 1 To m)
    
17.         Else
    
18.           brr = d(arr(i, 3))(arr(i, 8))
    
19.           m = UBound(brr, 2) + 1
    
20.           ReDim Preserve brr(1 To UBound(arr, 2), 1 To m)
    
21.         End If
    
22.         For j = 1 To UBound(arr, 2)
    
23.           brr(j, m) = arr(i, j)
    
24.         Next
    
25.         d(arr(i, 3))(arr(i, 8)) = brr
    
26.       End If
    
27.     Next
    
28.     .UsedRange.Offset(1, 0).ClearContents
    
29.     m = 2
    
30.     For Each aa In d.keys
    
31.       gs = ""
    
32.       For Each bb In d(aa).keys
    
33.         arr = d(aa)(bb)
    
34.         ReDim brr(1 To UBound(arr, 2), 1 To UBound(arr))
    
35.         For i = 1 To UBound(arr)
    
36.           For j = 1 To UBound(arr, 2)
    
37.             brr(j, i) = arr(i, j)
    
38.           Next
    
39.         Next
    
40.         .Cells(m, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
    
41.         .Cells(m + UBound(brr), 8) = "本月合计"
    
42.         .Cells(m + UBound(brr), 13).Resize(1, 4).FormulaR1C1 = "=SUM(R" & m & "C:R[-1]C)"
    
43.         gs = gs & "+" & "R" & m + UBound(brr) & "C"
    
44.         .Cells(m + UBound(brr) + 1, 8) = "本年累计"
    
45.         .Cells(m + UBound(brr) + 1, 13).Resize(1, 4).FormulaR1C1 = "=" & Mid(gs, 2)
    
46.         m = m + UBound(brr) + 2
    
47.       Next
    
48.     Next
    
49.   End With
    
50. End Sub
    

复制代码

chxw68

一题两解，又用字典写了一个，原始数据无需排序，以前的合计行也无需删除，不会重复合计的。

kezhiye

chxw68 发表于 2018-9-5 13:04
一题两解，又用字典写了一个，原始数据无需排序，以前的合计行也无需删除，不会重复合计的。

我正在修改附件，增加一行库存，因为增加一行库存后，库存后面也出现了本月合计和本年累计，实际上库存后面不要本月合计和本年累计。一会我上传附件后麻烦你再帮看看