Sub ertert()
Dim x, i&, j&, k&, s$, pl#
x = Range("A1:P69").Value
With Sheets("Лист2")
     .Range("A2:B" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
End With
With CreateObject("Scripting.Dictionary")
     .CompareMode = 1
     For i = 1 To UBound(x, 1)
         For j = 1 To UBound(x, 2)
             If Not IsNumeric(x(i, j)) Then
                 s = Trim(x(i, j)): k = (i \ 10) * 10 - (i < 10)
                 pl = x(i, 1) * x(k, j)
                 If .Exists(s) Then .Item(s) = .Item(s) + pl Else .Item(s) = pl
             End If
         Next j
     Next i
     Sheets("Лист2").Range("A2").Resize(.Count).Value = WorksheetFunction.Transpose(.keys)
     Sheets("Лист2").Range("B2").Resize(.Count).Value = WorksheetFunction.Transpose(.items)
End With
Sheets("Лист2").Activate
End Sub