Option Explicit
Sub TEST()
Dim Arr, Brr, Crr(1 To 1000, 1 To 6), i&, j%, R&, n%, xA As Range
Arr = [B2:G2]: Arr(1, 6) = "金額"
Set xA = [B3:H12]
For n = 0 To [B2].CurrentRegion.Columns.Count \ 5 - 1
Brr = xA.Offset(0, 5 * n)
For i = 1 To UBound(Brr)
If Val(Brr(i, 5)) = 0 Then GoTo i01
R = R + 1
For j = 1 To 5: Crr(R, j) = Brr(i, j): Next
i01: Next
Next
If R = 0 Then Exit Sub
With Workbooks.Add.Sheets(1)
.[A1].Resize(1, 6) = Arr
With .[A2].Resize(R + 1, 6)
.Value = Crr
.Columns(6) = "=D2*E2"
.Cells(R + 1, 5).Resize(1, 2) = "=SUM(E2:E" & R + 1 & ")"
End With
.[A1].CurrentRegion.Borders.Value = 1
End With
Set xA = Nothing: Erase Arr, Brr, Crr
End Sub
發表於 2023-7-26 14:20
| 
