Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Brr, Crr(1 To 1000, 1 To 3), Z, A, i&, R&, j%, N%, Y$, T$, xR As Range
ActiveSheet.UsedRange.Offset(, 6).EntireColumn.Delete
Y = InputBox("請確認是否正確!", "請輸入彙整年分", Format(CDate(Format(Date, "YYYY/MM/") & 1) - 1, "YYYY"))
If StrPtr(Y) = 0 Then Exit Sub
If Not Y Like "####" Then MsgBox "請輸入正確格式年份": Exit Sub
Set Z = CreateObject("Scripting.Dictionary"): Set xR = [G1]
Brr = [A1].CurrentRegion
For i = 2 To UBound(Brr)
If Not IsDate(Brr(i, 1)) Then GoTo i01
If Format(Brr(i, 1), "YYYY") <> Y Then GoTo i01 Else T = Brr(i, 2)
A = Z(T): R = Z(T & "/r")
If Not IsArray(A) Then A = Crr: N = N + 1
R = R + 1: A(R, 1) = Brr(i, 1): A(R, 2) = Brr(i, 3): A(R, 3) = Brr(i, 5)
Z(T) = A: Z(T & "/r") = R
i01: Next
If N = 0 Then Exit Sub
For i = 0 To Z.Count - 1
T = Z.KEYS()(i): If Not IsArray(Z(T)) Then GoTo i02
With xR.Resize(2, 3)
.Borders.LineStyle = xlContinuous
.Cells(1) = T: .Cells(2) = "支出明細表": .Cells(4) = "日期": .Cells(5) = "摘要": .Cells(6) = "支出"
For j = 7 To 10: .Borders(j).Weight = 4: Next
End With
xR.Interior.ColorIndex = 33: xR(2).Resize(, 3).Interior.ColorIndex = 1: xR(2).Resize(, 3).Font.ColorIndex = 2
With xR(3).Resize(Z(T & "/r"), 3)
.Value = Z(T)
.Item(.Count + 2) = "合計"
.Item(.Count + 3) = "=SUM(" & .Columns(3).Address & ")"
.Borders.LineStyle = xlContinuous
.ShrinkToFit = True
For j = 7 To 10: .Borders(j).Weight = 4: Next
End With
Set xR = xR(, 5)
i02: Next
End Sub作者: shan0948 時間: 2024-1-11 18:04
