Sub test()
Dim Arr, Brr, i&, j%
Arr = Range([b3], [c65536].End(3))
Brr = Range([g3], Cells(1, Columns.Count).End(1))
For j = 1 To UBound(Brr, 2)
For i = 2 To UBound(Arr)
If InStr(Arr(i, 1), Brr(1, j)) Then
Brr(3, j) = Brr(3, j) + Arr(i, 2)
End If
Next
Next
[g1].Resize(3, UBound(Brr, 2)) = Brr
End Sub