设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 如何用vba实现自动求和
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 10284|回复: 9

[已解决]如何用vba实现自动求和

[复制链接]
发表于 2015-3-17 21:04 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 旺小东 于 2015-3-19 09:02 编辑

如附件，如何按部分和序号汇总求和，我想用vba实现自动求和，请高手点招指教，多谢
最佳答案
月排行榜 / 总排行榜
grf1973
2015-3-19 08:54
  1. Sub Macro1()
  2.     Dim arr, i&, d
  3.     Set d = CreateObject("scripting.dictionary")
  4.     [h1:h10000] = ""
  5.     arr = Range("a1:f" & [a65536].End(3).Row)
  6.     ReDim brr(1 To UBound(arr), 1 To 1)
  7.     brr(1, 1) = "合计"
  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 Len(arr(i, 4)) Then brr(i, 1) = arr(i, 4) * arr(i, 6): s = s + brr(i, 1)
  13.             If Len(x) > 2 Then       '长度大于2，上一级自动汇总
  14.                 yrr = Split(x, "."): xl = Len(yrr(UBound(yrr))) '最后一部分长度
  15.                 y = Left(x, Len(x) - xl - 1)    '去掉最后一部分，到上一级
  16.                 d(y) = d(y) + brr(i, 1)
  17.             End If
  18.         Else
  19.             d.RemoveAll
  20.             brr(i, 1) = s
  21.             zs = zs + s: s = 0
  22.         End If
  23.     Next
  24.     brr(2, 1) = zs
  25.     Range("h1").Resize(UBound(arr)) = brr
  26. End Sub
复制代码
如何

用VBA自动求和.rar

9.76 KB, 下载次数: 29

相关帖子
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
dsmch
发表于 2015-3-17 22:03 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub Macro1()
  2. Dim arr, i&, d
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Range("a1").CurrentRegion
  5. s = 0: s1 = 0
  6. For i = UBound(arr) To 3 Step -1
  7.     If InStr(arr(i, 1), "部分") = 0 Then
  8.         If Len(arr(i, 2)) Then
  9.             arr(i, 4) = arr(i, 3) * arr(i, 2)
  10.             s1 = s1 + arr(i, 4)
  11.             z1 = "'" & Left(arr(i, 1), 1)
  12.             z2 = "'" & Left(arr(i, 1), 3)
  13.             z3 = "'" & Left(arr(i, 1), 5)
  14.             d(z1) = d(z1) + arr(i, 4)
  15.             d(z2) = d(z2) + arr(i, 4)
  16.             d(z3) = d(z3) + arr(i, 4)
  17.         Else
  18.             arr(i, 4) = d("'" & arr(i, 1))
  19.         End If
  20.     Else
  21.         d.RemoveAll
  22.         arr(i, 4) = s1
  23.         s = s + s1: s1 = 0
  24.     End If
  25. Next
  26. arr(2, 4) = s
  27. [d2:d10000] = ""
  28. Range("d1").Resize(UBound(arr)) = Application.Index(arr, 0, 4)
  29. End Sub
复制代码
回复

使用道具 举报

dsmch
发表于 2015-3-17 22:05 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
楼主模拟的结果有两处有误，请检查红色填充的单元格

用VBA自动求和.zip

15.13 KB, 下载次数: 32
回复

使用道具 举报

发表于 2015-3-17 22:41 | 显示全部楼层
本帖最后由 取不好网名 于 2015-3-17 22:43 编辑
  1. Sub kk()
  2. x = Sheet1.Range("a65536").End(3).Row
  3. Sheet1.Range("d2:d" & x).ClearContents
  4. arr = Sheet1.Range("a2:d" & x)
  5. For i = 1 To UBound(arr)
  6.   If Left(arr(i, 1), 1) = "总" Then
  7.      For j = i + 1 To UBound(arr)
  8.         arr(i, 4) = arr(i, 4) + arr(j, 2) * arr(j, 3)
  9.      Next
  10.   ElseIf Left(arr(i, 1), 1) = "第" Then
  11.      j = i + 1
  12.      Do While Left(arr(j, 1), 1) <> "第" And j < UBound(arr)
  13.         arr(i, 4) = arr(i, 4) + arr(j, 2) * arr(j, 3)
  14.         j = j + 1
  15.       Loop
  16.   Else
  17.     If arr(i, 2) = 0 Then
  18.       j = i + 1
  19.       Do While Left(arr(j, 1), Len(arr(i, 1))) = Left(arr(i, 1), Len(arr(i, 1))) And j < UBound(arr)
  20.         arr(i, 4) = arr(i, 4) + arr(j, 2) * arr(j, 3)
  21.         j = j + 1
  22.       Loop
  23.     Else
  24.       arr(i, 4) = arr(i, 2) * arr(i, 3)
  25.     End If
  26.   End If
  27. Next
  28. Sheet1.Range("a2").Resize(UBound(arr), 4) = arr
  29. End Sub
复制代码
回复

使用道具 举报

发表于 2015-3-17 23:29 | 显示全部楼层
dsmch 发表于 2015-3-17 22:05
楼主模拟的结果有两处有误，请检查红色填充的单元格

学习了！！！！
回复

使用道具 举报

grf1973
发表于 2015-3-18 16:10 | 显示全部楼层
换个思路，不管多少级都行。。。
  1. Sub Macro1()
  2.     Dim arr, i&, d
  3.     Set d = CreateObject("scripting.dictionary")
  4.     [d2:d10000] = ""
  5.     arr = Range("a1").CurrentRegion
  6.     For i = UBound(arr) To 3 Step -1
  7.         x = CStr(arr(i, 1))
  8.         If InStr(x, "部分") = 0 Then
  9.             If d.exists(x) Then arr(i, 4) = d(x)
  10.             If Len(arr(i, 2)) Then arr(i, 4) = arr(i, 3) * arr(i, 2): s = s + arr(i, 4)
  11.             If Len(x) > 2 Then       '长度大于2，上一级自动汇总
  12.                 yrr = Split(x, "."): yrr(UBound(yrr)) = 1  '把最后一部分搞成一位数
  13.                 x = Join(yrr, ".")
  14.                 y = Left(x, Len(x) - 2)      '去掉最后一部分，到上一级
  15.                 d(y) = d(y) + arr(i, 4)
  16.             End If
  17.         Else
  18.             d.RemoveAll
  19.             arr(i, 4) = s
  20.             zs = zs + s: s = 0
  21.         End If
  22.     Next
  23.     arr(2, 4) = zs
  24.     Range("d1").Resize(UBound(arr)) = Application.Index(arr, 0, 4)
  25. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2015-3-18 16:14 | 显示全部楼层
小改一下更容易理解一些。
  1. Sub Macro1()
  2.     Dim arr, i&, d
  3.     Set d = CreateObject("scripting.dictionary")
  4.     [d2:d10000] = ""
  5.     arr = Range("a1").CurrentRegion
  6.     For i = UBound(arr) To 3 Step -1
  7.         x = CStr(arr(i, 1))
  8.         If InStr(x, "部分") = 0 Then
  9.             If d.exists(x) Then arr(i, 4) = d(x)
  10.             If Len(arr(i, 2)) Then arr(i, 4) = arr(i, 3) * arr(i, 2): s = s + arr(i, 4)
  11.             If Len(x) > 2 Then       '长度大于2，上一级自动汇总
  12.                 yrr = Split(x, "."): xl = Len(yrr(UBound(yrr))) '最后一部分长度
  13.                 y = Left(x, Len(x) - xl - 1)    '去掉最后一部分，到上一级
  14.                 d(y) = d(y) + arr(i, 4)
  15.             End If
  16.         Else
  17.             d.RemoveAll
  18.             arr(i, 4) = s
  19.             zs = zs + s: s = 0
  20.         End If
  21.     Next
  22.     arr(2, 4) = zs
  23.     Range("d1").Resize(UBound(arr)) = Application.Index(arr, 0, 4)
  24. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-3-18 18:35 | 显示全部楼层
如果列数不变,各位大师的做法都对,只是在A、B列之间或B、C列之间或C、D列之间增加列是都提示下标越界，代码如何修改

用VBA自动求和(插入列).rar

13.53 KB, 下载次数: 56
回复

使用道具 举报

grf1973
发表于 2015-3-19 08:54 | 显示全部楼层    本楼为最佳答案   
  1. Sub Macro1()
  2.     Dim arr, i&, d
  3.     Set d = CreateObject("scripting.dictionary")
  4.     [h1:h10000] = ""
  5.     arr = Range("a1:f" & [a65536].End(3).Row)
  6.     ReDim brr(1 To UBound(arr), 1 To 1)
  7.     brr(1, 1) = "合计"
  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 Len(arr(i, 4)) Then brr(i, 1) = arr(i, 4) * arr(i, 6): s = s + brr(i, 1)
  13.             If Len(x) > 2 Then       '长度大于2，上一级自动汇总
  14.                 yrr = Split(x, "."): xl = Len(yrr(UBound(yrr))) '最后一部分长度
  15.                 y = Left(x, Len(x) - xl - 1)    '去掉最后一部分，到上一级
  16.                 d(y) = d(y) + brr(i, 1)
  17.             End If
  18.         Else
  19.             d.RemoveAll
  20.             brr(i, 1) = s
  21.             zs = zs + s: s = 0
  22.         End If
  23.     Next
  24.     brr(2, 1) = zs
  25.     Range("h1").Resize(UBound(arr)) = brr
  26. End Sub
复制代码

用VBA自动求和(插入列).rar

19.89 KB, 下载次数: 221
回复

使用道具 举报

 楼主| 发表于 2015-3-19 09:16 | 显示全部楼层
grf1973 发表于 2015-3-19 08:54

这回看明白了
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-27 04:50 , Processed in 0.424306 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表