按模板拆分明细，并分类汇总

老丢710

3190496160 发表于 2024-5-10 23:03
这么说太空宽泛了，没法回答你的，因为，不知道你的模板是什么样子，数据源是什么样子的

先感谢，新的模板是这样的，是否可以改动？

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
    If sh.Index > 2 Then
        sh.Delete
    End If
Next sh
With Sheets("数据")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 4 Then MsgBox "数据为空！": End
    ar = .Range("a3:k" & r)
End With
For i = 2 To UBound(ar)
    If ar(i, 6) <> "" Then
        If Not d.exists(ar(i, 6)) Then Set d(ar(i, 6)) = CreateObject("scripting.dictionary")
        d(ar(i, 6))(ar(i, 2)) = ""
    End If
Next i
For Each k In d.keys
    hj1 = 0: hj2 = 0: hj3 = 0: hj4 = 0: hj5 = 0
    Sheets("供应明细表").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = k
        .[a2] = "供应明细表--" & k
        For Each kk In d(k).keys
            n = 0
            ReDim br(1 To UBound(ar), 1 To 10)
            For i = 2 To UBound(ar)
                If ar(i, 6) = k And ar(i, 2) = kk Then
                    n = n + 1
                    br(n, 1) = n
                    For j = 2 To 5
                        br(n, j) = ar(i, j)
                    Next j
                    br(n, 6) = br(n, 5) * 0.05
                    br(n, 7) = DateSerial(Year(Date) + 1, Month(Date), Day(Date))
                    br(n, 8) = "5%"
                    br(n, 9) = br(n, 4) * 0.05
                    br(n, 10) = br(n, 9) * 1.06
                    hj1 = hj1 + br(n, 4)
                    hj2 = hj2 + br(n, 5)
                    hj3 = hj3 + br(n, 6)
                    hj4 = hj4 + br(n, 9)
                    hj5 = hj5 + br(n, 10)
                End If
            Next i
            rs = .Cells(Rows.Count, 3).End(xlUp).Row + 2
            If rs = 6 Then rs = 5
            .Cells(rs, 1).Resize(n, UBound(br, 2)) = br
            .Cells(rs, 1).Resize(n + 1, UBound(br, 2)).Borders.LineStyle = 1
            .Cells(rs + n, 2) = kk & " 小计"
            .Cells(rs + n, 4) = hj1
            .Cells(rs + n, 5) = hj2
            .Cells(rs + n, 6) = hj3
            .Cells(rs + n, 9) = hj4
            .Cells(rs + n, 10) = hj5
        Next kk
        For j = 4 To 10
            If j <> 7 And j <> 8 Then
                For i = 5 To 366
                    If InStr(.Cells(i, 2), "小计") > 0 Then
                        .Cells(367, j) = .Cells(367, j) + .Cells(i, j)
                    End If
                Next i
            End If
        Next j
        ws = .Cells(Rows.Count, 3).End(xlUp).Row + 2
        If ws <= 366 Then .Rows(ws & ":366").EntireRow.Hidden = True
        .[a1].Select
    End With
Next k
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok!"
End Sub

3190496160

模板2样表.rar (129.25 KB, 下载次数: 1)

2024-5-13 09:45 上传

点击文件名下载附件