|
|
Sub 套打()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
If r < 2 Then MsgBox "数据源为空！": End
ar = .Range(.Cells(1, 1), .Cells(r, 5))
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 4)) <> "" Then
d(ar(i, 4)) = ""
End If
Next i
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
For i = 2 To UBound(ar)
If ar(i, 4) = k Then
n = n + 1
For j = 1 To UBound(ar, 2)
br(n, j) = ar(i, j)
Next j
End If
Next i
With Sheets("套打")
.[a1].CurrentRegion.Offset(2).Borders.LineStyle = 0
.[a1].CurrentRegion.Offset(2) = Empty
.[a1] = Format(k, "yyyy-m-d") & "清单"
.[a3].Resize(n, UBound(br, 2)) = br
.[a3].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
.Cells(n + 3, 1) = "合计"
.Cells(n + 3, 5) = Application.Sum(Application.Index(br, 0, 5))
'.PrintPreview '显示打印预览
.PrintOut
End With
Next k
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-4-4 20:43
楼主
