a = Sheets("Данные").[a1].CurrentRegion.Columns(1).Resize(, 5).Value
For i = 2 To UBound(a)
t = Trim(a(i, 1))
If a(i, 5) > 0 Then d3.Item(t) = a(i, 5) 'норма расхода
Select Case Trim(a(i, 3))
Case "Сборка": d1.Item(t) = "Сборка"
Case "Покупные": d1.Item(t) = "Покупные"
Case "Кооперация": d1.Item(t) = "Покупные"
Case "Крепеж": d1.Item(t) = "Крепёж"
Case Else: d1.Item(t) = "Механический"
End Select
Next

Option Explicit
Sub tt()
    Dim a(), i&, d1 As Object, d2 As Object, d3 As Object, t$, k, kol As Object, el, x&

    Set d1 = CreateObject("scripting.dictionary"): d1.comparemode = 1
    Set d2 = CreateObject("scripting.dictionary"): d2.comparemode = 1
    Set d3 = CreateObject("scripting.dictionary"): d3.comparemode = 1    'норма расхода

    '1. набираем словарь номеров с именами листов по данным из "Данные"
    a = Sheets("Данные").[a1].CurrentRegion.Columns(1).Resize(, 5).Value
    For i = 2 To UBound(a)
        t = Trim(a(i, 1))
        If a(i, 5) > 0 Then d3.Item(t) = a(i, 5)    'норма расхода
        Select Case Trim(a(i, 3))
        Case "Крепёж": d1.Item(t) = "Покупные"
        End Select
    Next

    '2. "Итог" берём в массив, проходим циклом, проверяем номер по словарю - получаем имя листа,
    'который берём в другой словарь, где каждому имени листа собираем коллекцию номеров строк, которые в него будем копировать.

    a = Sheets("Итог").[a2].CurrentRegion.Columns(1).Resize(, 4).Value
    For i = 2 To UBound(a)
        t = Trim(a(i, 2))
        If d1.exists(t) Then
            If Not d2.exists(d1.Item(t)) Then d2.Add d1.Item(t), New Collection
            d2.Item(d1.Item(t)).Add i
        End If
    Next
     a = Sheets("Данные").[a1].CurrentRegion.Columns(1).Resize(, 5).Value
    For i = 2 To UBound(a)
        t = Trim(a(i, 1))
        If a(i, 5) > 0 Then d3.Item(t) = a(i, 5)
        Select Case Trim(a(i, 3))
        Case "Сборка": d1.Item(t) = "Сборка"
        Case "Крепёж": d1.Item(t) = "Крепёж"
        Case "Кооперация": d1.Item(t) = "Покупные"
        Case "Покупные": d1.Item(t) = "Покупные"
        Case Else: d1.Item(t) = "Механический"
          End Select
    Next
     a = Sheets("Итог").[a2].CurrentRegion.Columns(1).Resize(, 4).Value
    For i = 2 To UBound(a)
        t = Trim(a(i, 2))
        If d1.exists(t) Then
            If Not d2.exists(d1.Item(t)) Then d2.Add d1.Item(t), New Collection
            d2.Item(d1.Item(t)).Add i
        End If
    Next
    '3. цикл уже по словарю имён листов - берём ключ, создаём массив нужного размера (всё уже известно),
    'перекладываем в него данные из исходного массива, выгружаем на лист.

    For Each k In d2.keys
        Set kol = d2.Item(k)
        ReDim B(1 To kol.Count, 1 To 4) As String
        i = 0
        For Each el In kol
            i = i + 1
            B(i, 1) = i
            For x = 2 To 4: B(i, x) = a(el, x): Next
        Next
        With Sheets(k)
            .UsedRange.Offset(2).Clear
            .[a3].Resize(UBound(B), 4) = B
        End With
    Next
End Sub