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

Excel精英培训网

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

[已解决]项目汇总数据

[复制链接]
发表于 2014-12-31 11:37 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
用vba汇总项目和姓名对于的数据
最佳答案
月排行榜 / 总排行榜
grf1973
2014-12-31 14:00
  1. Sub tt()
  2.     arr = Sheet1.[a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")    '姓名+项目
  4.     Set d1 = CreateObject("scripting.dictionary")     '姓名
  5.     Set d2 = CreateObject("scripting.dictionary")     '项目
  6.     xmonth = [a2]
  7.     For i = 2 To UBound(arr)
  8.         If arr(i, 1) = xmonth Then
  9.             d1(arr(i, 2)) = ""
  10.             d2(arr(i, 3)) = ""
  11.             d(arr(i, 2) & arr(i, 3)) = d(arr(i, 2) & arr(i, 3)) + arr(i, 4)
  12.         End If
  13.     Next
  14.     [b5:b100,c4:n100].ClearContents
  15.     If d.Count = 0 Then MsgBox "无记录": Exit Sub
  16.     [b5].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  17.     [c4].Resize(1, d2.Count) = d2.keys
  18.     brr = [b4].CurrentRegion
  19.     For i = 2 To UBound(brr)
  20.         For j = 2 To UBound(brr, 2)
  21.             brr(i, j) = d(brr(i, 1) & brr(1, j))
  22.         Next
  23.     Next
  24.     [b4].CurrentRegion = brr
  25. End Sub
复制代码
项目

汇总表2014.12.31.rar

3.21 KB, 下载次数: 13

相关帖子

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
爱疯
发表于 2014-12-31 12:59 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
QQ截图20141231125333.jpg


QQ截图20141231125341.jpg




这都不用数据透视表？
就像不用勺子喝汤，哎


回复

使用道具 举报

grf1973
发表于 2014-12-31 14:00 | 显示全部楼层    本楼为最佳答案   
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub tt()
  2.     arr = Sheet1.[a1].CurrentRegion
  3.     Set d = CreateObject("scripting.dictionary")    '姓名+项目
  4.     Set d1 = CreateObject("scripting.dictionary")     '姓名
  5.     Set d2 = CreateObject("scripting.dictionary")     '项目
  6.     xmonth = [a2]
  7.     For i = 2 To UBound(arr)
  8.         If arr(i, 1) = xmonth Then
  9.             d1(arr(i, 2)) = ""
  10.             d2(arr(i, 3)) = ""
  11.             d(arr(i, 2) & arr(i, 3)) = d(arr(i, 2) & arr(i, 3)) + arr(i, 4)
  12.         End If
  13.     Next
  14.     [b5:b100,c4:n100].ClearContents
  15.     If d.Count = 0 Then MsgBox "无记录": Exit Sub
  16.     [b5].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
  17.     [c4].Resize(1, d2.Count) = d2.keys
  18.     brr = [b4].CurrentRegion
  19.     For i = 2 To UBound(brr)
  20.         For j = 2 To UBound(brr, 2)
  21.             brr(i, j) = d(brr(i, 1) & brr(1, j))
  22.         Next
  23.     Next
  24.     [b4].CurrentRegion = brr
  25. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-12-31 14:01 | 显示全部楼层
请看附件。

汇总表2014.12.31.rar

11.54 KB, 下载次数: 19
回复

使用道具 举报

 楼主| 发表于 2014-12-31 14:57 | 显示全部楼层
最后能否添合计数
回复

使用道具 举报

grf1973
发表于 2015-1-4 14:00 | 显示全部楼层
行列都加了合计。

汇总表2014.12.31.rar

11.94 KB, 下载次数: 9

评分

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

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-1-4 15:50 | 显示全部楼层
grf1973 发表于 2015-1-4 14:00
行列都加了合计。

感谢感谢！！！
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-24 03:59 , Processed in 0.351637 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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