Sub www()
    Dim i&, Dict As Object, a, j&
    If MsgBox("собрать?", vbYesNo + vbDefaultButton2) = 6 Then
        Set Dict = CreateObject("Scripting.Dictionary")
        Sheets(1).Range("a1").CurrentRegion.Clear
        For j = 2 To Sheets.Count
            With Sheets(j)
                a = .Range(.[a1], .[b65536].End(xlUp)).Value
                For i = 1 To UBound(a)
                    If Not Dict.exists(a(i, 1)) Then
                        Dict.Add a(i, 1), a(i, 2)
                    Else
                        Dict.Item(a(i, 1)) = Dict.Item(a(i, 1)) + a(i, 2)
                    End If
                Next
            End With
        Next
        Sheets(1).Range("a1").Resize(Dict.Count, 2) = Application.Transpose(Array(Dict.keys, Dict.items))
        Set Dict = Nothing: a = Empty
    End If
End Sub