```
Sub test() Dim a As Variant, lr, i, x, s, k, itm
a = Range("b3:b" & Cells(Rows.Count, 1).End(xlUp).Row).Resize(, 4)
With CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
If a(i, 2) = Range("m2") And a(i, 2) <> "" Then
If Not .exists(a(i, 1) & Chr(164) & a(i, 2) & Chr(164) & a(i, 3)) Then
.Add a(i, 1) & Chr(164) & a(i, 2) & Chr(164) & a(i, 3), a(i, 4)
Else
.Item(a(i, 1) & Chr(164) & a(i, 2) & Chr(164) & a(i, 3)) = .Item(a(i, 1) & Chr(164) & a(i, 2) & Chr(164) & a(i, 3)) + a(i, 4)
End If
End If
Next
k = .keys
itm = .items
[G:I].ClearContents
For i = 1 To .Count
x = Split(k(i - 1), Chr(164))
Range("g" & 3 + i - 1).Resize(, UBound(x) + 1) = x
Range("g" & 3 + i - 1).Offset(, 3) = itm(i - 1)
Next
End With
End Sub
```