Option Explicit

Dim wb As Workbook
Dim brr As Variant
Dim dic As Object
    
Sub Main()
    Dim arr As Variant
    arr = ActiveSheet.Range("A13:B35")
    brr = ActiveSheet.Range("A1:Q8")
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim y As Long
    For y = 1 To UBound(arr, 1)
        dic.Item(arr(y, 1)) = arr(y, 2)
    Next
    
    Set wb = Workbooks.Add(1)
    
    FormSet 2, 4
    FormSet 6
    FormSet 3, 1
    
    If wb.Sheets.Count > 1 Then
        Application.DisplayAlerts = False
        wb.Sheets(1).Delete
        Application.DisplayAlerts = True
    End If
    
    wb.Saved = True
    'wb.Close False
End Sub

Sub FormSet(ParamArray arr())
    Dim v As Variant
    Dim crr As Variant
    Dim diA As Object: Set diA = CreateObject("Scripting.Dictionary")
    diA.Item("Наименов.") = "Кол-во"
    Dim y As Long
    Dim x As Integer
    Dim s As String
    
    For Each v In arr
        x = 3 * (v - 1) + 1
        If x <= UBound(brr, 2) Then
            s = s & brr(1, x) & ", "
            For y = 3 To UBound(brr, 1)
                If brr(y, x) <> "" Then
                    If dic.Exists(brr(y, x)) Then
                        brr(y, x) = dic.Item(brr(y, x))
                    End If
                    If diA.Exists(brr(y, x)) Then
                        If diA.Item(brr(y, x)) < brr(y, x + 1) Then
                            diA.Item(brr(y, x)) = brr(y, x + 1)
                        End If
                    Else
                        diA.Item(brr(y, x)) = brr(y, x + 1)
                    End If
                End If
            Next
        End If
    Next
    s = Left(s, Len(s) - 2)
    
    Dim sh As Worksheet
    Set sh = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
    On Error Resume Next
    sh.Name = s
    On Error GoTo 0
    
    With sh.Cells(1, 1)
        .Cells(1, 1).Resize(diA.Count, 1) = Application.Transpose(diA.Keys())
        .Cells(1, 2).Resize(diA.Count, 1) = Application.Transpose(diA.Items())
    End With
End Sub