按月数据汇总

准提部林

szdcp 发表于 2023-2-22 13:50
谢谢大神回复，想要的格式如下

為了方便檢視, 還是做雙向排序//
Xl0000532-2.rar (29.27 KB, 下载次数: 26)

2023-2-22 19:24 上传

点击文件名下载附件

blackttea1

好程序，学习啦

今日123

把林老师的代码抄了一遍，学习老师代码有点理解，希望大家有补充的一起学习
Sub 汇总()
Dim arr, brr, s, ym, Sum, r, Rn, Col, Cn, i, j, Str, d As Object
Set d = CreateObject("Scripting.Dictionary")
With Sheet1
    arr = .UsedRange.Value
End With
With Sheet2
    brr = .[a1].Resize(UBound(arr), 250)
End With
For i = 2 To UBound(arr)
    s = arr(i, 1)
    ym = Format(arr(i, 6), "yyyymm")
    If s = "" Or Not IsDate(arr(i, 6)) Then GoTo i01 '排除空值和不是日期的值
    r = d(ym)               ' 月份 -  行
    Col = d(s)              ' 工厂 -  列
    If r = 0 Then
        Rn = Rn + 1         '计数有几个月份
        r = Rn + 2          '在第几行开始写入数据
        d(ym) = r           '得到新的月份的位置
        brr(r, 1) = ym      '把新的月份写到数组里
    End If
    If Col = 0 Then         '如果数组里的第二列是空值
        If Cn = 0 Then      '如果 关键字的 计数器 是 零
            Cn = 2          '关键字在第二列开始
        Else
            Cn = Cn + 6     '计数器 不是零的话 (计数器的值 + 6）
        End If
        Col = Cn            '得到下一个关键字 列 位置
        d(s) = Col
        For j = 0 To 5
            brr(1, Col + j) = s & IIf(j = 0, "", "_" & j) '
            brr(2, Col + j) = brr(2, j + 2) '标题依次写到数组
        Next j
    End If
    brr(r, Col) = brr(r, Col) + 1           '统计个数
    Sum = 0
    For j = 1 To 4
        Str = arr(i, j + 17)                   '要求和区域列的值
        Sum = Sum + Str
        If Str > 0 Then
            brr(r, Col + j) = brr(r, Col + j) + Str     '累加每一列的值
        End If
    Next j
    brr(r, Col + 5) = brr(r, Col + 5) + Sum              '合计
i01: Next i
If Cn * Rn = 0 Then Exit Sub
With Sheet2.[a1].Resize(Rn + 2, Cn + 5)
    .Cells(1, 2).Resize(3, 6).Copy .Cells(1, 2).Resize(3, Cn + 4)
     .Rows(3).Copy .Cells(3, 1).Resize(Rn)
     .Value = brr
     .Cells(1, 2).Resize(Rn + 2, Cn + 4).Sort _
            Key1:=.Cells(1, 2), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
     .Rows(1).Replace "*_*", ""
     .Cells(3, 1).Resize(Rn, Cn + 5).Sort _
            Key1:=.Cells(3, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
End With
End Sub