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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 求教条件统计代码？还请大侠帮忙
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1602|回复: 2

[已解决]求教条件统计代码？还请大侠帮忙

[复制链接]
发表于 2012-9-12 16:58 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
求教条件统计代码？还请大侠帮忙。在线跪求了。
最佳答案
月排行榜 / 总排行榜
suye1010
2012-9-12 19:03
  1. Option Explicit

  3. Sub lqxs()
  4. Dim arr, i&, aa, j&, Brr, z, nl
  5. Dim d, k, t
  6. Set d = CreateObject("Scripting.Dictionary")
  7. Sheet1.Activate
  8. arr = Sheet2.[a1].CurrentRegion
  9. For i = 3 To UBound(arr)
  10.     d(arr(i, 16)) = d(arr(i, 16)) & i & ","
  11. Next
  12. k = d.keys
  13. t = d.items
  14. ReDim Brr(1 To d.Count, 1 To 27) '定义数组到27
  15. For i = 0 To UBound(k)
  16.     Brr(i + 1, 1) = i + 1
  17.     Brr(i + 1, 2) = k(i)
  18.     aa = Split(t(i), ",")
  19.         For j = 0 To UBound(aa) - 1 '在这里不要去最后一个元素即相当于去除最后一个逗号
  20.             z = arr(aa(j), 4)    '指定区域为第4列
  21.             If Val(Mid(z, 17, 1)) Mod 2 = 1 Then    '如果第四列的一组数第17位能被2整除=1，那么在sheet1第4列中+1
  22.                 Brr(i + 1, 4) = Brr(i + 1, 4) + 1
  23.             Else
  24.                 Brr(i + 1, 5) = Brr(i + 1, 5) + 1 '否则在第五列中加1
  25.             End If
  26.             Brr(i + 1, 3) = Brr(i + 1, 3) + 1    '同时在第三列中+1
  27.             nl = DateSerial(Mid(z, 7, 4), Mid(z, 11, 2), Mid(z, 13, 2))  '取值
  28.             nl = DateDiff("yyyy", nl, Date)
  29.             Select Case nl
  30.                 Case 16 To 35
  31.                     Brr(i + 1, 7) = Brr(i + 1, 7) + 1
  32.                 Case 36 To 44
  33.                     Brr(i + 1, 8) = Brr(i + 1, 8) + 1
  34.                 Case 45 To 59
  35.                     Brr(i + 1, 9) = Brr(i + 1, 9) + 1
  36.                 Case 60 To 69
  37.                     Brr(i + 1, 10) = Brr(i + 1, 10) + 1
  38.                 Case 70 To 79
  39.                     Brr(i + 1, 11) = Brr(i + 1, 11) + 1
  40.                 Case 80 To 89
  41.                     Brr(i + 1, 12) = Brr(i + 1, 12) + 1
  42.                 Case Is >= 90
  43.                     Brr(i + 1, 13) = Brr(i + 1, 13) + 1
  44.             End Select
  45.             Brr(i + 1, 6) = Brr(i + 1, 6) + 1
  46.             
  47.            Select Case arr(aa(j), 10)
  48.                 Case 100
  49.                     Brr(i + 1, 15) = Brr(i + 1, 15) + 1
  50.                 Case 200
  51.                     Brr(i + 1, 16) = Brr(i + 1, 16) + 1
  52.                 Case 300
  53.                     Brr(i + 1, 17) = Brr(i + 1, 17) + 1
  54.                 Case 400
  55.                     Brr(i + 1, 18) = Brr(i + 1, 18) + 1
  56.                 Case 500
  57.                     Brr(i + 1, 19) = Brr(i + 1, 19) + 1
  58.                 Case 600
  59.                     Brr(i + 1, 20) = Brr(i + 1, 20) + 1
  60.                 Case 700
  61.                     Brr(i + 1, 21) = Brr(i + 1, 21) + 1
  62.                 Case 800
  63.                     Brr(i + 1, 22) = Brr(i + 1, 22) + 1
  64.                 Case 900
  65.                     Brr(i + 1, 23) = Brr(i + 1, 23) + 1
  66.                 Case 1000
  67.                     Brr(i + 1, 24) = Brr(i + 1, 24) + 1
  68.                End Select
  69.          
  70.             If arr(aa(j), 13) <> "" Then Brr(i + 1, 25) = Brr(i + 1, 25) + 1 '这里是处理特殊人群的。
  71.             Select Case arr(aa(j), 8)
  72.                 Case "新型农村社会养老保险"
  73.                     Brr(i + 1, 26) = Brr(i + 1, 26) + 1
  74.                 Case "城镇居民社会养老保险"
  75.                     Brr(i + 1, 27) = Brr(i + 1, 27) + 1
  76.             End Select
  77.         Next
  78.        Brr(i + 1, 14) = Brr(i + 1, 15) + Brr(i + 1, 16) + Brr(i + 1, 17) + Brr(i + 1, 18) + Brr(i + 1, 19) _
  79.                     + Brr(i + 1, 20) + Brr(i + 1, 21) + Brr(i + 1, 22) + Brr(i + 1, 23) + Brr(i + 1, 24)
  80. Next
  81. [b7].Resize(15, 27).ClearContents
  82. [a7].Resize(UBound(Brr), 27) = Brr
  83. End Sub
复制代码

条件统计.zip

26.17 KB, 下载次数: 7
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
发表于 2012-9-12 19:03 | 显示全部楼层    本楼为最佳答案   
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Option Explicit

  3. Sub lqxs()
  4. Dim arr, i&, aa, j&, Brr, z, nl
  5. Dim d, k, t
  6. Set d = CreateObject("Scripting.Dictionary")
  7. Sheet1.Activate
  8. arr = Sheet2.[a1].CurrentRegion
  9. For i = 3 To UBound(arr)
  10.     d(arr(i, 16)) = d(arr(i, 16)) & i & ","
  11. Next
  12. k = d.keys
  13. t = d.items
  14. ReDim Brr(1 To d.Count, 1 To 27) '定义数组到27
  15. For i = 0 To UBound(k)
  16.     Brr(i + 1, 1) = i + 1
  17.     Brr(i + 1, 2) = k(i)
  18.     aa = Split(t(i), ",")
  19.         For j = 0 To UBound(aa) - 1 '在这里不要去最后一个元素即相当于去除最后一个逗号
  20.             z = arr(aa(j), 4)    '指定区域为第4列
  21.             If Val(Mid(z, 17, 1)) Mod 2 = 1 Then    '如果第四列的一组数第17位能被2整除=1，那么在sheet1第4列中+1
  22.                 Brr(i + 1, 4) = Brr(i + 1, 4) + 1
  23.             Else
  24.                 Brr(i + 1, 5) = Brr(i + 1, 5) + 1 '否则在第五列中加1
  25.             End If
  26.             Brr(i + 1, 3) = Brr(i + 1, 3) + 1    '同时在第三列中+1
  27.             nl = DateSerial(Mid(z, 7, 4), Mid(z, 11, 2), Mid(z, 13, 2))  '取值
  28.             nl = DateDiff("yyyy", nl, Date)
  29.             Select Case nl
  30.                 Case 16 To 35
  31.                     Brr(i + 1, 7) = Brr(i + 1, 7) + 1
  32.                 Case 36 To 44
  33.                     Brr(i + 1, 8) = Brr(i + 1, 8) + 1
  34.                 Case 45 To 59
  35.                     Brr(i + 1, 9) = Brr(i + 1, 9) + 1
  36.                 Case 60 To 69
  37.                     Brr(i + 1, 10) = Brr(i + 1, 10) + 1
  38.                 Case 70 To 79
  39.                     Brr(i + 1, 11) = Brr(i + 1, 11) + 1
  40.                 Case 80 To 89
  41.                     Brr(i + 1, 12) = Brr(i + 1, 12) + 1
  42.                 Case Is >= 90
  43.                     Brr(i + 1, 13) = Brr(i + 1, 13) + 1
  44.             End Select
  45.             Brr(i + 1, 6) = Brr(i + 1, 6) + 1
  46.             
  47.            Select Case arr(aa(j), 10)
  48.                 Case 100
  49.                     Brr(i + 1, 15) = Brr(i + 1, 15) + 1
  50.                 Case 200
  51.                     Brr(i + 1, 16) = Brr(i + 1, 16) + 1
  52.                 Case 300
  53.                     Brr(i + 1, 17) = Brr(i + 1, 17) + 1
  54.                 Case 400
  55.                     Brr(i + 1, 18) = Brr(i + 1, 18) + 1
  56.                 Case 500
  57.                     Brr(i + 1, 19) = Brr(i + 1, 19) + 1
  58.                 Case 600
  59.                     Brr(i + 1, 20) = Brr(i + 1, 20) + 1
  60.                 Case 700
  61.                     Brr(i + 1, 21) = Brr(i + 1, 21) + 1
  62.                 Case 800
  63.                     Brr(i + 1, 22) = Brr(i + 1, 22) + 1
  64.                 Case 900
  65.                     Brr(i + 1, 23) = Brr(i + 1, 23) + 1
  66.                 Case 1000
  67.                     Brr(i + 1, 24) = Brr(i + 1, 24) + 1
  68.                End Select
  69.          
  70.             If arr(aa(j), 13) <> "" Then Brr(i + 1, 25) = Brr(i + 1, 25) + 1 '这里是处理特殊人群的。
  71.             Select Case arr(aa(j), 8)
  72.                 Case "新型农村社会养老保险"
  73.                     Brr(i + 1, 26) = Brr(i + 1, 26) + 1
  74.                 Case "城镇居民社会养老保险"
  75.                     Brr(i + 1, 27) = Brr(i + 1, 27) + 1
  76.             End Select
  77.         Next
  78.        Brr(i + 1, 14) = Brr(i + 1, 15) + Brr(i + 1, 16) + Brr(i + 1, 17) + Brr(i + 1, 18) + Brr(i + 1, 19) _
  79.                     + Brr(i + 1, 20) + Brr(i + 1, 21) + Brr(i + 1, 22) + Brr(i + 1, 23) + Brr(i + 1, 24)
  80. Next
  81. [b7].Resize(15, 27).ClearContents
  82. [a7].Resize(UBound(Brr), 27) = Brr
  83. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2012-9-13 09:19 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
谢谢suye老师，这个太好用了
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-5-15 21:23 , Processed in 0.181356 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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