Sub ertert()
Dim x, t, i&, wsh As Worksheet
With Sheets("итог")
     .Range("B2").CurrentRegion.Offset(1).ClearContents
     .Activate
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For Each wsh In ThisWorkbook.Worksheets
         If Not wsh Is ActiveSheet Then
             x = wsh.Range("B3").CurrentRegion.Value
             For i = 2 To UBound(x)
                 If .Exists(x(i, 1)) Then
                     t = .Item(x(i, 1))
                     t(2) = t(2) + x(i, 3)
                     .Item(x(i, 1)) = t
                 Else
                     .Item(x(i, 1)) = Array(x(i, 1), x(i, 2), x(i, 3))
                 End If
             Next i
         End If
     Next wsh
     Range("B3").Resize(.Count, 3).Value = Application.Index(.items, 0, 0)
End With
End Sub