Try this in "DATA" sheet:-
Sub MG18Jun22
Dim rng As Range, Dn As Range, n As Long, oSum As Long
Dim K As Variant, R As Range
Set rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Each Dn In rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Dn
Else
Set .Item(Dn.Value) = Union(.Item(Dn.Value), Dn)
End If
Next
For Each K In .keys
If .Item(K).Offset(, 4).Count > 1 Then
For Each R In .Item(K).Areas
With R.Offset(, 5)
.Merge
.Value = Application.Sum(R.Offset(, 4).Value)
End With
Next R
End If
Next K
End With
End Sub
Regards Mick
Bookmarks