Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 342|回复: 23

[已解决] [已解决]用VBA数组按开始结束日期 实现分类统计汇总

[复制链接]
发表于 2017-5-29 17:07 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
用VBA数组按开始结束日期   实现分类统计汇总


用VBA数组按开始结束日期 实现分类统计汇总.rar

9.27 KB, 下载次数: 20

金币
20  
积分
26 
帖子
1 
chart888发布于 2017-6-1 10:40:03 |显示全部回帖
本帖最后由 chart888 于 2017-6-1 11:05 编辑
  1. Private Sub CommandButton1_Click()
  2. On Error Resume Next

  3. Application.ScreenUpdating = False
  4. Application.DisplayAlerts = False

  5. Dim arr
  6. Dim arr1(1 To 10000, 1 To 20)
  7. Dim arr2(1 To 1, 1 To 20)
  8. Dim D1, D2, sInt
  9. Dim A1, A2, k, k1, x, m, n, i As Integer

  10. Set D1 = CreateObject("Scripting.Dictionary")
  11. Set D2 = CreateObject("Scripting.Dictionary")

  12. With Sheets("Sheet1")
  13. .Range("G1").CurrentRegion.Clear

  14. sInt = Application.InputBox(Prompt:="输入开始日期", Type:=1)
  15.     If Len(Trim(sInt)) > 7 Then
  16.         A1 = sInt
  17.     Else
  18.       MsgBox Prompt:="您没有输入有效的日期" & Chr(10) _
  19.             & "正确的月份格式为:(例:20150601)", Buttons:=vbOKOnly + vbInformation, _
  20.             Title:="错误提示"
  21.             Exit Sub
  22.     End If
  23. sInt = Application.InputBox(Prompt:="输入结束日期", Type:=1)
  24.     If Len(Trim(sInt)) > 7 Then
  25.         A2 = sInt
  26.     Else
  27.      MsgBox Prompt:="您没有输入有效的日期" & Chr(10) _
  28.             & "正确的月份格式为:(例:20150601)", Buttons:=vbOKOnly + vbInformation, _
  29.             Title:="错误提示"
  30.             Exit Sub
  31.     End If
  32. k1 = 3
  33. arr = .Range("A2:D" & .Range("A65536").End(xlUp).Row)
  34.     For x = 1 To UBound(arr)
  35.         If arr(x, 1) >= A1 And arr(x, 1) <= A2 Then
  36.             If D1.Exists(arr(x, 3)) Then
  37.                 n = D1(arr(x, 3))
  38.                     If D2.Exists(arr(x, 2)) Then
  39.                         m = D2(arr(x, 2))
  40.                         arr1(m, n) = arr1(m, n) + arr(x, 4)
  41.                         GoTo AA
  42.                     Else
  43.                         k = k + 1
  44.                         D2(arr(x, 2)) = k
  45.                         arr1(k, 1) = arr(x, 2)
  46.                         arr1(k, n) = arr(x, 4)
  47.                         GoTo AA
  48.                     End If
  49.             
  50.             Else
  51.                 k1 = k1 + 1
  52.                 D1(arr(x, 3)) = k1
  53.                 arr2(1, k1) = arr(x, 3)
  54.             End If
  55.                 If D2.Exists(arr(x, 2)) Then
  56.                     m = D2(arr(x, 2))
  57.                     arr1(m, n) = arr1(m, n) + arr(x, 4)
  58.                 Else
  59.                     k = k + 1
  60.                     D2(arr(x, 2)) = k
  61.                     arr1(k, 1) = arr(x, 2)
  62.                     arr1(k, k1 - 1) = arr(x, 4)
  63.                 End If
  64.     End If
  65. AA:
  66.     Next
  67. arr2(1, 1) = "开始—结束"
  68. arr2(1, 2) = "姓名"
  69. arr2(1, 3) = "销售额合计"
  70. .Range("H2").Resize(k, D1.Count + 2) = arr1
  71. .Range("G1").Resize(1, D1.Count + 3) = arr2
  72. .Range("G2") = A1
  73. .Range("G3") = A2
  74. .Cells(D2.Count + 2, 8) = "合计"
  75. For i = 2 To D2.Count + 1
  76.     .Cells(i, 9) = WorksheetFunction.Sum(.Range(Cells(i, 10).Address, Cells(i, D1.Count + 9).Address))
  77. Next
  78.     .Cells(D2.Count + 2, 9) = WorksheetFunction.Sum(.Range(Cells(2, 9).Address, Cells(D2.Count + 1, 9).Address))

  79. With .Range("G1").CurrentRegion.Borders
  80.     .LineStyle = xlContinuous
  81.     .Weight = xlThin
  82. End With
  83. With .Range("G1").Resize(D2.Count + 2, D1.Count + 3)
  84.     .EntireColumn.AutoFit
  85.     .VerticalAlignment = xlCenter
  86.     .HorizontalAlignment = xlCenter
  87.     .Font.Name = "微软雅黑"
  88.     .Font.Size = 11
  89. End With
  90. With .Range("G1").Resize(1, D1.Count + 3)
  91.     .Font.FontStyle = "Bold"
  92.     .Interior.ColorIndex = 34
  93. End With
  94. End With

  95. Application.ScreenUpdating = True
  96. Application.DisplayAlerts = True

  97. End Sub
复制代码

发表于 2017-5-29 17:28 | 显示全部楼层
用字典法可以很好解决, 大灰狼老师给过你很多范本, 参考后你可以自己实现. 具体有问题可以提问.



回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-29 17:31 | 显示全部楼层
france723 发表于 2017-5-29 17:28
用字典法可以很好解决, 大灰狼老师给过你很多范本, 参考后你可以自己实现. 具体有问题可以提问.

不懂要用数组方法

点评

数组法也可以, 略复杂而已. 我之前给你写的都是数组法, 可以参考  发表于 2017-5-29 17:33
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-29 17:32 | 显示全部楼层
france723 发表于 2017-5-29 17:28
用字典法可以很好解决, 大灰狼老师给过你很多范本, 参考后你可以自己实现. 具体有问题可以提问.


小猫这2条没有做

http://www.excelpx.com/thread-430649-1-1.html

VBA改写数组并且不要用find 可选择统计行数


http://www.excelpx.com/thread-430663-1-1.html

用VBA输入图案 不用rept函数还能用什么


回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-29 19:14 | 显示全部楼层
france723 发表于 2017-5-29 17:28
用字典法可以很好解决, 大灰狼老师给过你很多范本, 参考后你可以自己实现. 具体有问题可以提问.

你没有写啊

点评

让你参考我之前给你写的其他程序代码, 大同小异  发表于 2017-5-29 19:20
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-29 19:53 | 显示全部楼层
france723 发表于 2017-5-29 17:28
用字典法可以很好解决, 大灰狼老师给过你很多范本, 参考后你可以自己实现. 具体有问题可以提问.

不懂了这个
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-31 14:03 | 显示全部楼层
再顶一次了
回复 支持 反对

使用道具 举报

发表于 2017-5-31 14:42 | 显示全部楼层
没有看懂你的要求
你表达的和你给的模拟结果完全看不懂

评分

参与人数 1经验 +9 收起 理由
laoau138 + 9 来学习

查看全部评分

回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-31 15:03 | 显示全部楼层
chart888 发表于 2017-5-31 14:42
没有看懂你的要求
你表达的和你给的模拟结果完全看不懂

哪里不懂了
回复 支持 反对

使用道具 举报

发表于 2017-5-31 16:21 | 显示全部楼层
实现了部功能  你先看看  是不是要这样的
如果是的  我再完善后续的

用VBA数组按开始结束日期 实现分类统计汇总.zip

13.64 KB, 下载次数: 5

评分

参与人数 1经验 +9 收起 理由
laoau138 + 9 来学习

查看全部评分

回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2017-6-26 23:25 , Processed in 0.140400 second(s), 34 queries , Gzip On, Memcache On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

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