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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 将数据汇总
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 4635|回复: 11

[已解决]将数据汇总

[复制链接]
发表于 2014-12-30 13:01 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
如何将报账表和领款表中的数据按照月份和人名汇总到汇总表中
最佳答案
月排行榜 / 总排行榜
grf1973
2014-12-30 16:30
搞得太复杂了点吧。。。。看我的短代码。。。。。
  1. Sub tt()
  2.     Dim arr, brr, crr, d, i&, j%, k%, s&
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     For k = 1 To 2
  6.         brr = Sheets(k).Range("a1").CurrentRegion
  7.         For i = 2 To UBound(brr)
  8.             d(brr(i, 2)) = ""   '所有姓名
  9.             xk = Sheets(k).Name & brr(i, 1) & "月" & brr(i, 2)      '类型+月份+姓名
  10.             d1(xk) = d1(xk) + brr(i, 3)
  11.         Next
  12.     Next
  13.     Range("a3").Resize(d.Count, 1) = Application.Transpose(d.keys)  '填充姓名
  14.     arr = Range("a1").CurrentRegion
  15.     For i = 3 To UBound(arr)
  16.         For j = 2 To UBound(arr, 2)
  17.             If Len(arr(1, j)) = 0 Then arr(1, j) = arr(1, j - 1)      '考虑合并单元格
  18.             xk = arr(2, j) & arr(1, j) & arr(i, 1)
  19.             arr(i, j) = d1(xk)
  20.         Next
  21.     Next
  22.     Range("a3").CurrentRegion = arr
  23. End Sub
复制代码

汇总表2014.12.30.rar

2.98 KB, 下载次数: 19
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
xdragon
发表于 2014-12-30 14:53 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub total()
  2.     Dim d As Object
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Dim arr, i&, j%, re, sr$
  5.     arr = Sheets("报账").Range("A1").CurrentRegion.Value
  6.     For i = 2 To UBound(arr)
  7.         sr = arr(i, 1) & "|" & arr(i, 2)
  8.         If Not d.exists(arr(i, 2)) Then Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
  9.         If Not d(arr(i, 2)).exists(arr(i, 1)) Then
  10.             d(arr(i, 2))(arr(i, 1)) = Array(arr(i, 3), 0)
  11.         Else
  12.             d(arr(i, 2))(arr(i, 1)) = Array(d(arr(i, 2))(arr(i, 1))(0) + arr(i, 3), 0)
  13.         End If
  14.     Next
  15.     arr = Sheets("领款").Range("A1").CurrentRegion.Value
  16.     For i = 2 To UBound(arr)
  17.         sr = arr(i, 1) & "|" & arr(i, 2)
  18.         If Not d.exists(arr(i, 2)) Then Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
  19.         If Not d(arr(i, 2)).exists(arr(i, 1)) Then
  20.             d(arr(i, 2))(arr(i, 1)) = Array(0, arr(i, 3))
  21.         Else
  22.             d(arr(i, 2))(arr(i, 1)) = Array(d(arr(i, 2))(arr(i, 1))(0), d(arr(i, 2))(arr(i, 1))(1) + arr(i, 3))
  23.         End If
  24.     Next
  25.     arr = d.keys
  26.     ReDim re(1 To d.Count, 1 To 25)
  27.     For i = 1 To UBound(re)
  28.         re(i, 1) = arr(i - 1)
  29.         For j = 2 To 25 Step 2
  30.             If d(re(i, 1)).exists(j / 2) Then re(i, j) = d(re(i, 1))(j / 2)(0): re(i, j + 1) = d(re(i, 1))(j / 2)(1)
  31.         Next
  32.     Next
  33.     Range("A3").Resize(UBound(re), UBound(re, 2)) = re
  34. End Sub
复制代码

点评

dsmch
一个字典就够了，不需要用数组字典  发表于 2014-12-30 15:11

评分

参与人数 1 +3 收起 理由
雄鹰2013 + 3 赞一个!

查看全部评分

回复

使用道具 举报

dsmch
发表于 2014-12-30 15:08 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 dsmch 于 2014-12-30 17:08 编辑
  1. Sub Macro1()
  2. Dim arr, brr, crr, d, i&, j%, k%, s&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Range("a1").CurrentRegion
  5. ReDim crr(1 To 50000, 1 To UBound(arr, 2))
  6. For j = 2 To UBound(arr, 2)
  7.     arr(1, j) = Replace(arr(1, j), "月", "")
  8.     If arr(1, j) = "" Then arr(1, j) = arr(1, j - 1)
  9. Next
  10. For k = 1 To 2
  11.     brr = Sheets(k).Range("a1").CurrentRegion
  12.     gzb = Sheets(k).Name
  13.     For i = 2 To UBound(brr)
  14.         If Not d.exists(brr(i, 2)) Then
  15.             s = s + 1
  16.             crr(s, 1) = brr(i, 2)
  17.             d(brr(i, 2)) = ""
  18.         End If
  19.         zf = brr(i, 1) & "," & brr(i, 2) & "," & gzb
  20.         d(zf) = d(zf) + brr(i, 3)
  21.     Next
  22. Next
  23. For i = 1 To s
  24.     For j = 2 To UBound(arr, 2)
  25.         zf = arr(1, j) & "," & crr(i, 1) & "," & arr(2, j)
  26.         crr(i, j) = d(zf)
  27.     Next
  28. Next
  29. Range("a3").Resize(s, UBound(crr, 2)) = crr
  30. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
雄鹰2013 + 3 赞一个!

查看全部评分

回复

使用道具 举报

dsmch
发表于 2014-12-30 15:10 | 显示全部楼层
………………

汇总表2014.12.30.zip

9.98 KB, 下载次数: 13

点评

xdragon
呵呵，纯碎想玩玩这种方法罢了，反正能达到目的就行了。你的数组不也是还用了替换吗？直接1到12不就行了  发表于 2014-12-30 15:31
回复

使用道具 举报

芐雨
发表于 2014-12-30 15:45 | 显示全部楼层
  1. Sub 按钮4_Click()
  2.     Dim arr, brr, crr, d As Object
  3.     Dim i&, n%, m%
  4.     arr = Sheets("报账").Range("A1").CurrentRegion
  5.     brr = Sheets("领款").Range("A1").CurrentRegion
  6.     ReDim crr(1 To 1000, 24)
  7.     Set d = CreateObject("scripting.dictionary")
  8.     For i = 2 To UBound(arr)
  9.         m = arr(i, 1) * 2 - 1
  10.         If Not d.exists(arr(i, 2)) Then
  11.             n = n + 1
  12.             d(arr(i, 2)) = n
  13.             crr(n, 0) = arr(i, 2)
  14.         End If
  15.         crr(d(arr(i, 2)), m) = arr(i, 3)
  16.     Next
  17.     For i = 2 To UBound(brr)
  18.         m = brr(i, 1) * 2
  19.         If Not d.exists(brr(i, 2)) Then
  20.             n = n + 1
  21.             d(brr(i, 2)) = n
  22.             crr(n, 0) = brr(i, 2)
  23.         End If
  24.         crr(d(brr(i, 2)), m) = brr(i, 3)
  25.     Next
  26.     With Sheets("汇总")
  27.         .Range("A1").CurrentRegion.Offset(2).Clear
  28.         .Range("A3").Resize(n, 25) = crr
  29.         .Range("A1").CurrentRegion.Borders.LineStyle = 1
  30.     End With
  31. End Sub
复制代码

评分

参与人数 1 +3 收起 理由
雄鹰2013 + 3 很给力!

查看全部评分

回复

使用道具 举报

xdragon
发表于 2014-12-30 16:17 | 显示全部楼层
再给你个sql的解决方案吧
QQ截图20141230161458.jpg

汇总表2014.12.30.rar

15.56 KB, 下载次数: 26
回复

使用道具 举报

grf1973
发表于 2014-12-30 16:30 | 显示全部楼层    本楼为最佳答案   
搞得太复杂了点吧。。。。看我的短代码。。。。。
  1. Sub tt()
  2.     Dim arr, brr, crr, d, i&, j%, k%, s&
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     For k = 1 To 2
  6.         brr = Sheets(k).Range("a1").CurrentRegion
  7.         For i = 2 To UBound(brr)
  8.             d(brr(i, 2)) = ""   '所有姓名
  9.             xk = Sheets(k).Name & brr(i, 1) & "月" & brr(i, 2)      '类型+月份+姓名
  10.             d1(xk) = d1(xk) + brr(i, 3)
  11.         Next
  12.     Next
  13.     Range("a3").Resize(d.Count, 1) = Application.Transpose(d.keys)  '填充姓名
  14.     arr = Range("a1").CurrentRegion
  15.     For i = 3 To UBound(arr)
  16.         For j = 2 To UBound(arr, 2)
  17.             If Len(arr(1, j)) = 0 Then arr(1, j) = arr(1, j - 1)      '考虑合并单元格
  18.             xk = arr(2, j) & arr(1, j) & arr(i, 1)
  19.             arr(i, j) = d1(xk)
  20.         Next
  21.     Next
  22.     Range("a3").CurrentRegion = arr
  23. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-12-30 16:32 | 显示全部楼层
另外，三楼的代码有误，把20句改成：d(zf) = d(zf) + brr(i, 3) 就对了

点评

dsmch
多谢提醒，已修改  发表于 2014-12-30 16:51
回复

使用道具 举报

grf1973
发表于 2014-12-30 16:46 | 显示全部楼层
参考5楼思路，最短代码来啦。。。。。
  1. Sub ttt()
  2.     Dim crr(1 To 1000, 24)
  3.     Set d = CreateObject("scripting.dictionary")
  4.     For k = 1 To 2
  5.         brr = Sheets(k).Range("a1").CurrentRegion
  6.         For i = 2 To UBound(brr)
  7.             m = brr(i, 1) * 2 - k Mod 2
  8.             If Not d.exists(brr(i, 2)) Then
  9.                 n = n + 1
  10.                 d(brr(i, 2)) = n
  11.                 crr(n, 0) = brr(i, 2)
  12.             End If
  13.             crr(d(brr(i, 2)), m) = crr(d(brr(i, 2)), m) + brr(i, 3)
  14.         Next
  15.     Next
  16.     Range("A3").Resize(n, 25) = crr
  17. End Sub
复制代码
回复

使用道具 举报

芐雨
发表于 2014-12-30 17:26 | 显示全部楼层
grf1973 发表于 2014-12-30 16:46
参考5楼思路，最短代码来啦。。。。。

{:361:} 最短是6楼的SQL代码吧
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-19 11:17 , Processed in 0.416344 second(s), 18 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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