ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2700|回复: 17

[求助] 将62列数据按日期顺序且存在跨月的情况汇总

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-8-1 22:41 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
一个月的交易数据,量比较大,且每天收到的单据日期不统一,希望实现将表内明细数据转换成按日期时间顺序,且有跨月的情况进行汇总,按月份小计,最后总计。请各大神指教,谢谢
aaa.rar (7.36 KB, 下载次数: 14)

TA的精华主题

TA的得分主题

发表于 2018-8-1 23:54 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
如图
D1.gif

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-8-1 23:56 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-8-2 09:22 | 显示全部楼层
本帖最后由 dagal 于 2018-8-2 11:57 编辑

汇总数据不对呢,没有把各列中的日期金额进行合并呀。比如6-25就不止912,在其他列里也有6-25的数据,没有累加进来

TA的精华主题

TA的得分主题

发表于 2018-8-2 12:37 | 显示全部楼层
dagal 发表于 2018-8-2 09:22
汇总数据不对呢,没有把各列中的日期金额进行合并呀。比如6-25就不止912,在其他列里也有6-25的数据,没有 ...

已经调整了。
再有这段代码没有进行日期大小排序,不知道你自己是否能优化。
2/不支持跨年,如果跨年,会按月份相同的进行统计的,你注意下。

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-8-2 13:00 | 显示全部楼层
不知道为什么 发表于 2018-8-2 12:37
已经调整了。
再有这段代码没有进行日期大小排序,不知道你自己是否能优化。
2/不支持跨年,如果跨年, ...

Range("A1").CurrentRegion.Sort [a1000], xlAscending, Header:=xlYes这个排序的

这个小计加在最后with里变成所有包含小计也进行了排序,加在上面又没起作用。。。

TA的精华主题

TA的得分主题

发表于 2018-8-2 13:41 | 显示全部楼层
dagal 发表于 2018-8-2 13:00
Range("A1").CurrentRegion.Sort [a1000], xlAscending, Header:=xlYes这个排序的

这个小计加在最后wi ...

我的思路 是在数组输出的时候按照日期重小到大的顺序输出。没有用单元格的排序。类似上面的月份由小到大的思路。

TA的精华主题

TA的得分主题

发表于 2018-8-2 14:09 | 显示全部楼层
  1. Sub Test2()
  2.     Dim arrSource As Variant, lngKey As Long, dblItem As Double, dblSum As Double
  3.     Dim lngRows As Long, lngCols As Long
  4.     Dim objDicAll As Object, arrKeys As Variant
  5.     Dim objDicMonth As Object, lngMonth As Long
  6.     Dim lngRow As Long, lngCol As Long
  7.     Dim arrResult As Variant, lngIndex As Long
  8.    
  9.     arrSource = Sheet1.UsedRange
  10.     lngRows = UBound(arrSource)
  11.     lngCols = UBound(arrSource, 2)
  12.    
  13.     Set objDicAll = CreateObject("Scripting.Dictionary")
  14.     Set objDicMonth = CreateObject("Scripting.Dictionary")
  15.    
  16.     For lngCol = 1 To lngCols Step 2
  17.         For lngRow = 2 To lngRows
  18.             If arrSource(lngRow, lngCol) <> "" And arrSource(lngRow, lngCol + 1) <> "" Then
  19.                 lngKey = Format(CStr(arrSource(lngRow, lngCol)), "yyyymmdd")
  20.                 dblItem = arrSource(lngRow, lngCol + 1)
  21.                 objDicAll(lngKey) = objDicAll(lngKey) + dblItem
  22.                 lngKey = Mid(lngKey, 1, 6)
  23.                 objDicMonth(lngKey) = objDicMonth(lngKey) + dblItem
  24.                 dblSum = dblSum + dblItem
  25.             End If
  26.         Next
  27.     Next
  28.    
  29.     lngRows = objDicAll.Count + objDicMonth.Count + 1
  30.     ReDim arrResult(1 To lngRows, 1 To 2)
  31.    
  32.     arrKeys = objDicAll.keys
  33.     lngIndex = 1
  34.    
  35.     For lngRow = 1 To UBound(arrKeys) + 1
  36.         lngKey = Application.WorksheetFunction.Small(arrKeys, lngRow)
  37.         dblItem = objDicAll(lngKey)
  38.         
  39.         If lngMonth = 0 Then
  40.             lngMonth = Mid(lngKey, 1, 6)
  41.         Else
  42.             If Mid(lngKey, 1, 6) <> lngMonth Then
  43.                 arrResult(lngIndex, 1) = "小计"
  44.                 arrResult(lngIndex, 2) = objDicMonth(lngMonth)
  45.                 lngIndex = lngIndex + 1
  46.                 lngMonth = Mid(lngKey, 1, 6)
  47.             End If
  48.         End If
  49.         
  50.         arrResult(lngIndex, 1) = Format(lngKey, "0/00/00")
  51.         arrResult(lngIndex, 2) = dblItem
  52.         lngIndex = lngIndex + 1
  53.     Next
  54.    
  55.     arrResult(lngIndex, 1) = "小计"
  56.     arrResult(lngIndex, 2) = objDicMonth(lngMonth)
  57.     lngIndex = lngIndex + 1
  58.    
  59.     arrResult(lngIndex, 1) = "合计"
  60.     arrResult(lngIndex, 2) = dblSum
  61.    
  62.     Sheet2.Range("A2:B" & Rows.Count).ClearContents
  63.     Sheet2.Range("A2").Resize(lngIndex, 2) = arrResult
  64.    
  65.     MsgBox "OK"
  66. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-8-2 14:25 | 显示全部楼层
  1. Sub Test2()
  2.     Dim arrSource As Variant, lngKey As Long, dblItem As Double, dblSum As Double
  3.     Dim lngRows As Long, lngCols As Long
  4.     Dim objDicAll As Object, arrKeys As Variant
  5.     Dim objDicMonth As Object, lngMonth As Long
  6.     Dim lngRow As Long, lngCol As Long
  7.     Dim arrResult As Variant, lngIndex As Long
  8.    
  9.     arrSource = Sheet1.UsedRange
  10.     lngRows = UBound(arrSource)
  11.     lngCols = UBound(arrSource, 2)
  12.    
  13.     Set objDicAll = CreateObject("Scripting.Dictionary")
  14.     Set objDicMonth = CreateObject("Scripting.Dictionary")
  15.    
  16.     For lngCol = 1 To lngCols Step 2
  17.         For lngRow = 2 To lngRows
  18.             If arrSource(lngRow, lngCol) <> "" And arrSource(lngRow, lngCol + 1) <> "" Then
  19.                 lngKey = Format(CStr(arrSource(lngRow, lngCol)), "yyyymmdd")
  20.                 dblItem = arrSource(lngRow, lngCol + 1)
  21.                 objDicAll(lngKey) = objDicAll(lngKey) + dblItem
  22.                 lngKey = Mid(lngKey, 1, 6)
  23.                 objDicMonth(lngKey) = objDicMonth(lngKey) + dblItem
  24.                 dblSum = dblSum + dblItem
  25.             End If
  26.         Next
  27.     Next
  28.    
  29.     lngRows = objDicAll.Count + objDicMonth.Count + 1
  30.     ReDim arrResult(1 To lngRows, 1 To 2)
  31.    
  32.     arrKeys = objDicAll.keys
  33.     lngIndex = 1
  34.    
  35.     For lngRow = 1 To UBound(arrKeys) + 1
  36.         lngKey = Application.WorksheetFunction.Small(arrKeys, lngRow)
  37.         dblItem = objDicAll(lngKey)
  38.         
  39.         If lngMonth = 0 Then
  40.             lngMonth = Mid(lngKey, 1, 6)
  41.         Else
  42.             If Mid(lngKey, 1, 6) <> lngMonth Then
  43.                 arrResult(lngIndex, 1) = "小计"
  44.                 arrResult(lngIndex, 2) = objDicMonth(lngMonth)
  45.                 lngIndex = lngIndex + 1
  46.                 lngMonth = Mid(lngKey, 1, 6)
  47.             End If
  48.         End If
  49.         
  50.         arrResult(lngIndex, 1) = Format(lngKey, "0/00/00")
  51.         arrResult(lngIndex, 2) = dblItem
  52.         lngIndex = lngIndex + 1
  53.     Next
  54.    
  55.     arrResult(lngIndex, 1) = "小计"
  56.     arrResult(lngIndex, 2) = objDicMonth(lngMonth)
  57.     lngIndex = lngIndex + 1
  58.    
  59.     arrResult(lngIndex, 1) = "合计"
  60.     arrResult(lngIndex, 2) = dblSum
  61.    
  62.     Sheet2.Range("A2:B" & Rows.Count).ClearContents
  63.     Sheet2.Range("A2").Resize(lngIndex, 2) = arrResult
  64.    
  65.     MsgBox "OK"
  66. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-8-2 14:26 | 显示全部楼层
Sub Test2()
    Dim arrSource As Variant, lngKey As Long, dblItem As Double, dblSum As Double
    Dim lngRows As Long, lngCols As Long
    Dim objDicAll As Object, arrKeys As Variant
    Dim objDicMonth As Object, lngMonth As Long
    Dim lngRow As Long, lngCol As Long
    Dim arrResult As Variant, lngIndex As Long
   
    arrSource = Sheet1.UsedRange
    lngRows = UBound(arrSource)
    lngCols = UBound(arrSource, 2)
   
    Set objDicAll = CreateObject("Scripting.Dictionary")
    Set objDicMonth = CreateObject("Scripting.Dictionary")
   
    For lngCol = 1 To lngCols Step 2
        For lngRow = 2 To lngRows
            If arrSource(lngRow, lngCol) <> "" And arrSource(lngRow, lngCol + 1) <> "" Then
                lngKey = Format(CStr(arrSource(lngRow, lngCol)), "yyyymmdd")
                dblItem = arrSource(lngRow, lngCol + 1)
                objDicAll(lngKey) = objDicAll(lngKey) + dblItem
                lngKey = Mid(lngKey, 1, 6)
                objDicMonth(lngKey) = objDicMonth(lngKey) + dblItem
                dblSum = dblSum + dblItem
            End If
        Next
    Next
   
    lngRows = objDicAll.Count + objDicMonth.Count + 1
    ReDim arrResult(1 To lngRows, 1 To 2)
   
    arrKeys = objDicAll.keys
    lngIndex = 1
   
    For lngRow = 1 To UBound(arrKeys) + 1
        lngKey = Application.WorksheetFunction.Small(arrKeys, lngRow)
        dblItem = objDicAll(lngKey)
        
        If lngMonth = 0 Then
            lngMonth = Mid(lngKey, 1, 6)
        Else
            If Mid(lngKey, 1, 6) <> lngMonth Then
                arrResult(lngIndex, 1) = "小计"
                arrResult(lngIndex, 2) = objDicMonth(lngMonth)
                lngIndex = lngIndex + 1
                lngMonth = Mid(lngKey, 1, 6)
            End If
        End If
        
        arrResult(lngIndex, 1) = Format(lngKey, "0/00/00")
        arrResult(lngIndex, 2) = dblItem
        lngIndex = lngIndex + 1
    Next
   
    arrResult(lngIndex, 1) = "小计"
    arrResult(lngIndex, 2) = objDicMonth(lngMonth)
    lngIndex = lngIndex + 1
   
    arrResult(lngIndex, 1) = "合计"
    arrResult(lngIndex, 2) = dblSum
   
    Sheet2.Range("A2:B" & Rows.Count).ClearContents
    Sheet2.Range("A2").Resize(lngIndex, 2) = arrResult
   
    MsgBox "OK"
End Sub
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2025-1-11 11:14 , Processed in 0.028179 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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