[已解决]各位大师，当增加列数时，自动求和又如何修改代码

旺小东

各位大师，当增加列数时，用各位的方法又如何修改代码。（最好是每录入一个数量完成时，自动求和）

最佳答案

月排行榜 / 总排行榜

grf1973

2015-3-20 09:07

1. Sub Macro1()
   
2.     Dim arr, i&, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     [i1:k10000] = ""
   
6.     arr = Range("a1:h" & [a65536].End(3).Row)
   
7.     ReDim brr(1 To UBound(arr), 1 To 3)
   
8.     For i = UBound(arr) To 3 Step -1
   
9.         x = CStr(arr(i, 1))
   
10.         If InStr(x, "部分") = 0 Then
    
11.             If d.exists(x) Then brr(i, 1) = d(x)
    
12.             If d1.exists(x) Then brr(i, 2) = d1(x)
    
13.             If Len(arr(i, 6)) Then
    
14.                 brr(i, 1) = arr(i, 6) * arr(i, 7): s = s + brr(i, 1)
    
15.                 brr(i, 2) = arr(i, 6) * arr(i, 8): s1 = s1 + brr(i, 2)
    
16.             End If
    
17.             If Len(x) > 2 Then       '长度大于2，上一级自动汇总
    
18.                 yrr = Split(x, "."): xl = Len(yrr(UBound(yrr))) '最后一部分长度
    
19.                 y = Left(x, Len(x) - xl - 1)    '去掉最后一部分，到上一级
    
20.                 d(y) = d(y) + brr(i, 1)
    
21.                 d1(y) = d1(y) + brr(i, 2)
    
22.             End If
    
23.         Else
    
24.             d.RemoveAll: d1.RemoveAll
    
25.             brr(i, 1) = s: brr(i, 2) = s1
    
26.             zs = zs + s: s = 0
    
27.             zs1 = zs1 + s1: s1 = 0
    
28.         End If
    
29.         brr(i, 3) = brr(i, 1) + brr(i, 2)
    
30.     Next
    
31.     brr(2, 1) = zs: brr(2, 2) = zs1: brr(2, 3) = zs + zs1
    
32.     Range("i1").Resize(UBound(arr), 3) = brr
    
33.     Range("i1").Resize(1, 3) = Array("工程费（元）", "设备费（元）", "合计（元）")
    
34. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub Macro1()
   
2.     Dim arr, i&, d
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     [i1:k10000] = ""
   
6.     arr = Range("a1:h" & [a65536].End(3).Row)
   
7.     ReDim brr(1 To UBound(arr), 1 To 3)
   
8.     For i = UBound(arr) To 3 Step -1
   
9.         x = CStr(arr(i, 1))
   
10.         If InStr(x, "部分") = 0 Then
    
11.             If d.exists(x) Then brr(i, 1) = d(x)
    
12.             If d1.exists(x) Then brr(i, 2) = d1(x)
    
13.             If Len(arr(i, 6)) Then
    
14.                 brr(i, 1) = arr(i, 6) * arr(i, 7): s = s + brr(i, 1)
    
15.                 brr(i, 2) = arr(i, 6) * arr(i, 8): s1 = s1 + brr(i, 2)
    
16.             End If
    
17.             If Len(x) > 2 Then       '长度大于2，上一级自动汇总
    
18.                 yrr = Split(x, "."): xl = Len(yrr(UBound(yrr))) '最后一部分长度
    
19.                 y = Left(x, Len(x) - xl - 1)    '去掉最后一部分，到上一级
    
20.                 d(y) = d(y) + brr(i, 1)
    
21.                 d1(y) = d1(y) + brr(i, 2)
    
22.             End If
    
23.         Else
    
24.             d.RemoveAll: d1.RemoveAll
    
25.             brr(i, 1) = s: brr(i, 2) = s1
    
26.             zs = zs + s: s = 0
    
27.             zs1 = zs1 + s1: s1 = 0
    
28.         End If
    
29.         brr(i, 3) = brr(i, 1) + brr(i, 2)
    
30.     Next
    
31.     brr(2, 1) = zs: brr(2, 2) = zs1: brr(2, 3) = zs + zs1
    
32.     Range("i1").Resize(UBound(arr), 3) = brr
    
33.     Range("i1").Resize(1, 3) = Array("工程费（元）", "设备费（元）", "合计（元）")
    
34. End Sub
    

复制代码