Option Explicit

Sub main()    'with using reference MS Scripting Runtime
Dim arr, i&, d As New Dictionary
d.CompareMode = 1
With Sheets("Перечень")
        arr = .Range("B3:D" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
End With

For i = 1 To UBound(arr)
        Call ertert(d, CStr(arr(i, 1)), arr(i, 3))
Next i
With Sheets("Итог")
        .Activate
        .Range("a3:d" & Rows.Count).ClearContents
End With
With Sheets("Итог").Range("B3:D3").Resize(d.Count)
        .Columns(1).Value = Application.Transpose(d.Keys)
        .Columns(3).Value = Application.Transpose(d.Items)
        .Sort Key1:=.Cells(1, 1), Order1:=xlAscending
        .Parent.Activate
End With
End Sub

Option Explicit
Dim rez(), n&

Sub main()    'with using reference MS Scripting Runtime
Dim arr, i&, d As New Dictionary
d.CompareMode = 1: n = 0: ReDim rez(1 To 10000, 1 To 4)
With Sheets("Перечень")
     arr = .Range("B3:D" & .Cells(Rows.Count, 2).End(xlUp).Row).Value
End With

For i = 1 To UBound(arr)
     Call ertert(d, CStr(arr(i, 1)), arr(i, 3))
Next i
d.RemoveAll
With Sheets("Итог").Range("A3:D3")
     .CurrentRegion.Offset(2).ClearContents
     .Resize(n).Value = rez()
     .Parent.Activate
End With
End Sub

Sub ertert(d As Dictionary, ByVal t As String, ByVal k As Long)
Dim x, j&, s$, r As Range
Set r = Sheets("Состав узлов").Columns(1).Find(t, LookIn:=xlValues, lookat:=xlWhole)
If r Is Nothing Then MsgBox "oops: " & t, 48: Exit Sub
x = r.CurrentRegion.Value
For j = 1 To UBound(x)
     s = CStr(x(j, 3))
     If d.Exists(s) Then
         rez(d.Item(s), 4) = rez(d.Item(s), 4) + x(j, 5) * k
     Else
         n = n + 1: d.Item(s) = n
         rez(n, 1) = n
         rez(n, 2) = s
         rez(n, 3) = x(j, 4)
         rez(n, 4) = x(j, 5) * k
     End If
     If Left(s, 1) = 3 Or Left(s, 1) = 6 Then ertert d, s, x(j, 5) * k
Next j
End Sub