Public Sub GPE()
Application.ScreenUpdating = False
Dim sArr(), dArr(), tArr(), LuBu(), I As Long, J As Long, K As Long, Num As Long
Dim Cll As Range, DK As Long, N As Long, M As Long, MaxR As Long
sArr = Range([A2], [A2].End(xlDown).Offset(1)).Resize(, 4).Value
DK = Range("J2").Value
ReDim dArr(1 To UBound(sArr, 1) * 3, 1 To 4)
ReDim tArr(1 To UBound(sArr, 1) * 3, 1 To 4)
For I = 1 To UBound(sArr, 1) - 1
K = K + 1
For J = 1 To 4
dArr(K, J) = sArr(I, J)
Next J
Num = Num + sArr(I, 4)
If sArr(I, 3) <> sArr(I + 1, 3) Then
K = K + 1
dArr(K, 2) = "TOTAL: " & sArr(I, 3)
dArr(K, 4) = Num
If Num > DK Then
N = N + 1
tArr(N, 1) = sArr(I, 3)
tArr(N, 2) = Num - DK
ElseIf Num < DK Then
M = M + 1
tArr(M, 3) = sArr(I, 3)
tArr(M, 4) = DK - Num
End If
Num = 0
End If
Next I
With [F2:I2]
.Resize(1000).Clear
.Resize(K) = dArr
.Resize(K).Borders.LineStyle = 1
End With
[K2:M1000].ClearContents
[K2:M1000].ClearContents
MaxR = IIf(N > M, N, M)
If MaxR Then
[K2].Resize(MaxR, 4) = tArr
[K2].Resize(MaxR, 4).Borders.LineStyle = 1
End If
For Each Cll In Range("G2").Resize(K)
If Left(Cll, 5) = "TOTAL" Then
With Cll.Offset(, -1).Resize(, 4)
.Interior.ColorIndex = 20
.Font.Bold = True
.Font.ColorIndex = 3
End With
End If
Next Cll
End Sub
