如何把一个汇总表按不同内容要求进行拆分，感谢大神。

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long
Dim br()
Dim rn As Range, rng As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 4 Then MsgBox "汇总表为空！": End
    ar = .Range("a2:l" & r - 3)
    Set rn = .Range("a" & r - 2 & ":i" & r)
    Set rng = .Range("a1:i3")
End With
For i = 3 To UBound(ar)
    If ar(i, 10) = "" Then ar(i, 10) = ar(i - 1, 10)
    If ar(i, 12) = "" Then ar(i, 12) = ar(i - 1, 12)
    s = ar(i, 12)
    If Not d.exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
    d(s)(i) = ar(i, 10)
Next i
Application.SheetsInNewWorkbook = 1
For Each k In d.keys
    n = 0: hj = 0
    ReDim br(1 To d(k).Count, 1 To 9)
    For Each kk In d(k).keys
        dp = ar(kk, 10)
        n = n + 1
        For j = 1 To 9
            br(n, j) = ar(kk, j)
        Next j
    Next kk
    Set wb = Workbooks.Add
    With wb.Worksheets(1)
        .Name = k
        rng.Copy .[a1]
        .[a2] = "店铺名：" & dp & "                            金额：元"
        .[a4].Resize(n, UBound(br, 2)) = br
        .[a4].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
        rn.Copy .Cells(n + 4, 1)
        .Cells(n + 5, 8).FormulaR1C1 = "=SUM(R[-" & n + 1 & "]C:R[-1]C)"
    End With
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".xlsx"
    wb.Close
Next k
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

增加了店铺名和合计公式代码
新建文件夹.rar (20.84 KB, 下载次数: 2)

2024-11-1 08:23 上传

点击文件名下载附件

zf531

感谢这么早就回复帖的，万分感谢。
合计有合计了，但每一行的小计没有公式计算。