|
'看不太懂,先给你凑一个,,,
Option Explicit
Sub test()
Dim arr, i, j, p, sum, pos
arr = [a1].CurrentRegion.Offset(1).Resize(, 13).Value
ReDim brr(1 To UBound(arr, 1) * 2, 1 To UBound(arr, 2)), sum(UBound(arr, 2))
pos = Array(8, 10, 11, 12, 13)
For i = 1 To UBound(arr, 1) - 1
sum(pos(0)) = sum(pos(0)) + arr(i, 6) * arr(i, 7)
sum(pos(1)) = sum(pos(1)) + arr(i, 6) * arr(i, 9)
For j = 2 To UBound(pos) - 1
sum(pos(j)) = sum(pos(j)) + arr(i, pos(j))
Next
If arr(i, 1) <> arr(i + 1, 1) Then
For j = 0 To UBound(pos) - 1
arr(p + 1, pos(j)) = sum(pos(j)): sum(pos(j)) = 0
Next
arr(p + 1, pos(j)) = arr(p + 1, pos(0)) - arr(p + 1, pos(1))
p = i
End If
Next
Call doevent(False)
With [a24]
.Resize(UBound(arr, 1) * 2, UBound(arr, 2)).Clear
With .Resize(UBound(arr, 1) - 1, UBound(arr, 2))
.Borders.LineStyle = xlContinuous
.Value = arr
End With
End With
p = 24
For i = 24 To [a24].End(xlDown).Row
If Cells(i, "a").Value <> Cells(i + 1, "a").Value Or i = [a24].End(xlDown).Row Then
For j = 0 To UBound(pos)
Cells(p, pos(j)).Resize(i - p + 1).Merge
Next
p = i + 1
End If
Next
Call doevent(True)
End Sub
Function doevent(flag As Boolean)
With Application
.DisplayAlerts = flag
.ScreenUpdating = flag
End With
End Function |
评分
-
1
查看全部评分
-
|