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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求段代码实现以下功能，具体见附件，谢谢
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 2854|回复: 8

[已解决]求段代码实现以下功能，具体见附件，谢谢

[复制链接]
发表于 2012-2-9 12:54 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
其中的利用字典求和我会，但是怎么把数据填入到要去的行中，想不出办法，请高手帮忙，具体见附件，谢谢
最佳答案
月排行榜 / 总排行榜
liuguansky
2012-2-9 14:05
  1. Sub tt()
  2.     Dim D As New Dictionary, Arr, I&, ArrR(), ar, dk
  3.     Arr = Range("A2:c" & Cells(Rows.Count, 1).End(3).Row).Value
  4.     ReDim ArrR(1 To UBound(Arr), 1 To 2)
  5.     For I = 1 To UBound(Arr)
  6.         If D.Exists(Arr(I, 1)) Then
  7.             ar = D(Arr(I, 1))
  8.             ar(0) = ar(0) + Arr(I, 3)
  9.             ar(1) = ar(1) + 1
  10.             D(Arr(I, 1)) = ar
  11.         Else
  12.             D.Add Arr(I, 1), Array(Arr(I, 3), 1)
  13.         End If
  14.     Next I
  15.     For Each dk In D.Keys
  16.         ar = D(dk)
  17.         D(dk) = ar(0) / ar(1)
  18.     Next dk
  19.     For I = 1 To UBound(Arr)
  20.         ArrR(I, 2) = Arr(I, 3) / D(Arr(I, 1))
  21.     Next I
  22.     For I = 1 To UBound(Arr)
  23.         If D.Exists(Arr(I, 1)) Then
  24.             ArrR(I, 1) = D(Arr(I, 1))
  25.             D.Remove Arr(I, 1)
  26.         End If
  27.     Next I
  28.     Range("d2:e" & Rows.Count).ClearContents
  29.     Range("d2").Resize(UBound(ArrR), 2) = ArrR
  30. End Sub
复制代码
求助.rar (12.55 KB, 下载次数: 32)

求助.rar

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

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2012-2-9 14:05 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub tt()
  2.     Dim D As New Dictionary, Arr, I&, ArrR(), ar, dk
  3.     Arr = Range("A2:c" & Cells(Rows.Count, 1).End(3).Row).Value
  4.     ReDim ArrR(1 To UBound(Arr), 1 To 2)
  5.     For I = 1 To UBound(Arr)
  6.         If D.Exists(Arr(I, 1)) Then
  7.             ar = D(Arr(I, 1))
  8.             ar(0) = ar(0) + Arr(I, 3)
  9.             ar(1) = ar(1) + 1
  10.             D(Arr(I, 1)) = ar
  11.         Else
  12.             D.Add Arr(I, 1), Array(Arr(I, 3), 1)
  13.         End If
  14.     Next I
  15.     For Each dk In D.Keys
  16.         ar = D(dk)
  17.         D(dk) = ar(0) / ar(1)
  18.     Next dk
  19.     For I = 1 To UBound(Arr)
  20.         ArrR(I, 2) = Arr(I, 3) / D(Arr(I, 1))
  21.     Next I
  22.     For I = 1 To UBound(Arr)
  23.         If D.Exists(Arr(I, 1)) Then
  24.             ArrR(I, 1) = D(Arr(I, 1))
  25.             D.Remove Arr(I, 1)
  26.         End If
  27.     Next I
  28.     Range("d2:e" & Rows.Count).ClearContents
  29.     Range("d2").Resize(UBound(ArrR), 2) = ArrR
  30. End Sub
复制代码
求助.rar (12.55 KB, 下载次数: 32)
回复

使用道具 举报

zjdh
发表于 2012-2-9 14:18 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
  1. Sub test()
  2.     Set D = CreateObject("scripting.dictionary")
  3.     ARR = Range("A2:F" & Range("A65536").End(3).Row)
  4.     For I = 1 To UBound(ARR)
  5.         If Not D.exists(ARR(I, 1)) Then
  6.             D.Add ARR(I, 1), I
  7.             ARR(D(ARR(I, 1)), 4) = ARR(D(ARR(I, 1)), 3)
  8.             ARR(D(ARR(I, 1)), 6) = 1
  9.         Else
  10.             ARR(D(ARR(I, 1)), 4) = ARR(D(ARR(I, 1)), 4) + ARR(I, 3)
  11.             ARR(D(ARR(I, 1)), 6) = ARR(D(ARR(I, 1)), 6) + 1
  12.         End If
  13.     Next
  14.     For I = 1 To UBound(ARR)
  15.        If ARR(I, 4) <> "" Then
  16.        ARR(I, 4) = ARR(I, 4) / ARR(I, 6)
  17.        ARR(I, 5) = ARR(I, 3) / ARR(I, 4)
  18.        Else
  19.        ARR(I, 5) = ARR(I, 3) / ARR(D(ARR(I, 1)), 4)
  20.        End If
  21.     Next
  22.     Range("A2").Resize(UBound(ARR), 5) = ARR
  23. End Sub
复制代码
计算平均值.rar (11.59 KB, 下载次数: 10)
回复

使用道具 举报

zyouong
发表于 2012-2-9 14:21 | 显示全部楼层
求助.rar (6.77 KB, 下载次数: 4)
回复

使用道具 举报

csmctjg
发表于 2012-2-9 14:27 | 显示全部楼层
字典套数组：

  2. Sub aa()
  3. Dim i&, j&
  4. Dim arr, brr()
  5. Dim d As New Dictionary
  6. arr = Sheets("Sheet1").Range("A2:C" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row)
  7. ReDim brr(1 To UBound(arr), 1 To 2)
  8. For i = 1 To UBound(arr)
  9.     If Not d.Exists(arr(i, 1)) Then
  10.         d(arr(i, 1)) = Array(i, 0, 0)
  11.     End If
  12.     d(arr(i, 1)) = Array(d(arr(i, 1))(0), d(arr(i, 1))(1) + arr(i, 3), d(arr(i, 1))(2) + 1)
  13. Next i
  14. For i = 1 To UBound(arr)
  15.     If i = d(arr(i, 1))(0) Then brr(i, 1) = d(arr(i, 1))(1) / d(arr(i, 1))(2)
  16.     brr(i, 2) = arr(i, 3) / (d(arr(i, 1))(1) / d(arr(i, 1))(2))
  17. Next i
  18. Sheets("Sheet1").[D2].Resize(UBound(arr), 2) = brr
  19. End Sub
复制代码

评分

参与人数 3 +50 金币 +30 收起 理由
liuts + 10 很给力!学习了，要是把brr省掉就更精简啦
zjdh + 10 很给力!
爱疯 + 30 + 30 神马都是浮云

查看全部评分

回复

使用道具 举报

zjdh
发表于 2012-2-9 14:28 | 显示全部楼层
3楼的宏就是把房号次序打乱了，结果也不会错误。
回复

使用道具 举报

zjdh
发表于 2012-2-9 14:42 | 显示全部楼层
本帖最后由 zjdh 于 2012-2-9 14:45 编辑

回复点评：
当然不在话下
其实5楼的思路比较新颖！
回复

使用道具 举报

 楼主| 发表于 2012-2-9 16:20 | 显示全部楼层
zjdh 发表于 2012-2-9 14:18

谢谢，都 能实现功能，感谢你们了
回复

使用道具 举报

 楼主| 发表于 2012-2-9 16:20 | 显示全部楼层
csmctjg 发表于 2012-2-9 14:27
字典套数组：

谢谢，感谢你们了，非常感谢
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-5-15 23:56 , Processed in 0.311223 second(s), 11 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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