Sub tt()
r = .End(3).Row
arr = Range("a2:d" & r)
r1 = .End(3).Row
brr = Range("i2:j" & r1)
For i = 1 To UBound(brr)
For k = 2 To UBound(arr)
If InStr(arr(k, 2), brr(i, 1)) > 0 Then brr(i, 2) = brr(i, 2) + arr(k, 4)
Next
Next
Range("i2:j" & r1) = brr
End Sub
Sub tt()
r = [b65536].End(3).Row
arr = Range("a2:d" & r)
r1 = [i65536].End(3).Row
brr = Range("i2:j" & r1)
For i = 1 To UBound(brr)
For k = 2 To UBound(arr)
If InStr(arr(k, 2), brr(i, 1)) > 0 Then brr(i, 2) = brr(i, 2) + arr(k, 4)
Next
Next
Range("i2:j" & r1) = brr
End Sub
Sub Macro1()
Dim arr, brr, d, i&
Set d = CreateObject("scripting.dictionary")
arr = Range("a3:d" & Range("a65536").End(xlUp).Row)
brr = Range("i2").CurrentRegion
For i = 1 To UBound(arr)
d(arr(i, 2)) = d(arr(i, 2)) + arr(i, 4)
Next
For i = 1 To UBound(brr)
brr(i, 1) = d(brr(i, 1))
Next
Range("j2").Resize(UBound(brr)) = brr
End Sub