Sub main()    'with using reference MS Scripting Runtime
      
     Dim arr, s, i&, p&, d As New Dictionary, st_dic As New Dictionary
     Dim struct, key, k
     Dim st()
     Dim tmp()
     Dim rez()
      
     ReDim st(0 To 100, 0 To 2)
     p = 0
     d.CompareMode = 1
      
     struct = Лист5.Range("A3", "E" & Лист5.Range("C60000").End(xlUp).Row + 1).Value
     For i = 1 To UBound(struct)
         If Len(struct(i, 1)) Then
             If Not st_dic.Exists(struct(i, 1)) Then st_dic.Add struct(i, 1), i
         End If
     Next i
      
     arr = Лист1.Range("B3:D" & Лист1.Cells(Rows.Count, 2).End(xlUp).Row).Value
      
     For i = 1 To UBound(arr)
         If Len(Trim(arr(i, 1))) Then
             p = p + 1
             st(p, 0) = Trim(arr(i, 1))
             st(p, 1) = Trim(arr(i, 3))
         End If
     Next i
     Erase arr
      
     While p > 0
         If st_dic.Exists(st(p, 0)) Then
             k = st(p, 1)
             i = st_dic(st(p, 0))
             p = p - 1
             s = Trim(struct(i, 3))
             While Not s = ""
                 If Left(s, 1) = 3 Or Left(s, 1) = 6 Then
                     p = p + 1
                     st(p, 0) = s
                     st(p, 1) = struct(i, 5) * k 'Было st(p, 1) = Val(struct(i, 5)) * k
                     st(p, 2) = 1
                 End If
                 If d.Exists(s) Then
                     tmp = d(s)
                 Else
                     ReDim tmp(1 To 3)
                     tmp(1) = s
                     d.Add s, tmp
                 End If
                 tmp(2) = struct(i, 4)
                 tmp(3) = tmp(3) + struct(i, 5) * k  'Было tmp(3) = tmp(3) + Val(struct(i, 5)) * k
                 d(s) = tmp
                 i = i + 1
                 s = Trim(struct(i, 3))
             Wend
         Else
             MsgBox "Не разузлован: " & st(p, 0), 48, "ВНИМАНИЕ":
             If st(p, 2) = 1 Then
                 If d.Exists(st(p, 0)) Then
                     tmp = d(st(p, 0))
                 Else
                     ReDim tmp(1 To 3)
                     tmp(1) = st(p, 0)
                     d.Add st(p, 0), tmp
                 End If
                 tmp(2) = "!!!Не разузлован"
                 tmp(3) = tmp(3) + k
                 d(st(p, 0)) = tmp
             End If
             p = p - 1
         End If
     Wend
      
     Erase struct
     ReDim rez(1 To d.Count, 1 To 4)
     p = 0
     For Each key In d.Keys
         p = p + 1
         rez(p, 1) = p
         For i = 1 To 3
             rez(p, i + 1) = d(key)(i)
         Next i
     Next key
     d.RemoveAll
      
     With Sheets("Итог").Range("A3:D3")
          .CurrentRegion.Offset(2).ClearContents
          .Resize(p).Value = rez()
          .Parent.Activate
     End With
     Range("E3").Select
End Sub