Private Sub Worksheet_Change(ByVal Target As Range)
Dim V, L&, F&, R&, W, C(), S$(), N%, X, K%
Select Case Split(Target.Address, ":")(0)
Case "$F$3", "$C$4", "$E$4"
Case Else
Exit Sub
End Select
With Application
V = .Match("#", Me.UsedRange.Columns(1), 0): If IsError(V) Then Beep: Exit Sub
L = V - 5
.EnableEvents = False
With Range("A7:F" & L)
.ClearContents
.Columns(2).NumberFormat = "General"
.Font.Bold = False
.Interior.ColorIndex = xlNone
End With
.EnableEvents = True
If [(A1>0)+(N(F3)=0)+ISBLANK(C4)+ISBLANK(E4)] Then
If L > 8 Then [A:F].Rows(8).Resize(L - 8).Delete xlUp
Exit Sub
End If
With Sheet1.[B1].CurrentRegion
V = .Parent.Evaluate(Replace("IF({1},YEAR(A4:A#)&""¤""&B4:B#&""¤""&C4:C#)", "#", .Rows.Count))
V = Application.Match([YEAR(F3)&"¤"&C4&"¤"&E4], V, 0): If IsError(V) Then Beep: Exit Sub
F = V + 3
V = Evaluate("{" & Replace(.Cells(F, 5).Text, "-", ",") & "}"): If IsError(V) Then Beep: Exit Sub
With .Columns("F:BE")
R = Application.Count(.Rows(F)): If R = 0 Then Beep: Exit Sub
W = Application.Index(.Value2, Array(1, 3, F), Evaluate("ROW(1:" & .Count & ")"))
ReDim C(1 To UBound(V)), S(1 To UBound(V))
For N = 1 To .Count
If Application.IsNumber(W(N, 3)) Then
X = Application.Match(.Cells(F, N).Interior.Color, C, 0)
If IsError(X) Then
K = K + 1: If K > UBound(V) Then Beep: Exit Sub
C(K) = .Cells(F, N).Interior.Color
S(K) = "{" & N
Else
S(X) = S(X) & ";" & N
End If
End If
Next
End With
End With
If K < UBound(V) Then Beep: Exit Sub
.EnableEvents = False
.ScreenUpdating = False
R = 6 + R - L + K * 2
If R < 0 Then
[A:F].Rows(L + R).Resize(-R).Delete xlUp
ElseIf R Then
[A:F].Rows(L).Resize(R).Insert xlDown
[B7:D7].Copy Cells(L, 2).Resize(R)
End If
R = 7
For N = 1 To K
X = Evaluate(S(N) & "}")
With Rows(R).Columns("A:E")
.Font.Bold = True
.Interior.Color = C(N)
.Item("A:B") = Array("PART-" & N, V(N) & "%")
.Item(5).Formula = "=A5*B" & R & "&"" kg """
End With
With Rows(R + 1).Resize(UBound(X)).Columns
.Item("A:B").Value2 = Application.Index(W, X, [{1,2}])
.Item(5).Value2 = Application.Index(W, X, 3)
.Item(6).Formula = "=A$5*B$" & R & "*E" & R + 1 & "%"
End With
With Rows(R + 1 + UBound(X)).Columns("B:F")
.Font.Bold = True
.Item(1).Value2 = "Total PART-" & N
.Item("D:E").Formula = "=SUM(E" & R + 1 & ":E" & .Row - 1 & ")"
R = .Row + 1
End With
Next
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub