按月数据汇总

szdcp

菜鸟求助各位大神


             附件中的文件有三个工作表，“统计”是数据源，“样式”是我要的格式，sheet1是运行宏后的结果，运行宏可以达到我的要求，但是每次运行完后需要重新整理才可以提交给别人，否则太难看，有没有其它方法可以直接生成工作表“样式”中的格式。谢谢各位

蓝桥玄霜

计数的例子：

zxsea_7426

没有使用公式

今日123

zxsea_7426 发表于 2023-2-20 21:31
没有使用公式

老师的代码有几处小更正下，
for i1=1 to 12 ,改为 for i1= 0 to ubound(mon_)
还有
br(2,m+j)=cr(j-1)
不然会出现下标越界的错误
数组的下标是零。
还望老师指正

今日123

这是模仿上面老师的代码写的请改正
Sub 汇总()
Dim arr, brr, crr, br, cr, i, j, k, k1, key1, r, s, sum, n, m, d As Object
Set d = CreateObject("Scripting.Dictionary")
crr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12)
cr = Array("计数", "外观", "组装", "包装", "机能", "合计")
k1 = UBound(cr) + 1
With Sheets("统计")
    arr = .[a1].CurrentRegion
    For i = 2 To UBound(arr)
        If Not d.exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        s = Format(Month(arr(i, 6)), "m月")
        If Not d(arr(i, 1)).exists(s) Then
            ReDim brr(1 To 6)
            brr(1) = 1 '计数
            sum = 0
            For j = 2 To 5
                brr(j) = arr(i, j + 16)
                sum = sum + brr(j)
            Next j
            brr(6) = sum '合计
            d(arr(i, 1))(s) = brr
        Else
            brr = d(arr(i, 1))(s)
            brr(1) = brr(1) + 1
            For j = 2 To 5
                brr(j) = brr(j) + arr(i, j + 16)
                brr(6) = brr(6) + arr(i, j + 16) '合计
            Next j
            d(arr(i, 1))(s) = brr
        End If
    Next i
    ReDim br(1 To d.Count + 3, 1 To k1 * d.Count)
    br(2, 1) = "工厂名"
    br(d.Count + 3, 1) = "总结"
    r = 2
    For Each k In d.keys
        r = r + 1
        m = 1
        For i = 0 To UBound(crr)
            key1 = crr(i) & "月"
            If d(k).exists(key1) Then
                br(1, m + 1) = key1
                br(r, 1) = k
                For j = 1 To k1
                    br(r, m + j) = d(k)(key1)(j)
                    br(2, m + j) = cr(j - 1)
                    br(d.Count + 3, m + j) = br(d.Count + 3, m + j) + d(k)(key1)(j) '总结合计
                Next j
                m = m + k1
            End If
        Next i
    Next k
End With
With Sheets("sheet1")
    .Cells.Clear
    With .[b1].Resize(UBound(br), UBound(br, 2))
        .Value = br
    End With
    Set Rng = .[b1].CurrentRegion
    With Intersect(Rng, Rng.Offset(0, 1))
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
    For i = 2 To UBound(br, 2) Step k1
        .Cells(1, 1 + i).Resize(1, k1).Merge
    Next i
End With
End Sub

今日123

参考附件代码

mmwwdd

mmwwdd

SQL 汇总能使程序简单些

mmwwdd

弄完了，还得审核，醒的早

zxsea_7426

今日123 发表于 2023-2-20 23:29
老师的代码有几处小更正下，
for i1=1 to 12 ,改为 for i1= 0 to ubound(mon_)
还有

我第一行强制下标起始为1