Sub Test()
    Dim q, w, e As Long

    Общее = Worksheets("Лист1").Range("J60000").End(xlUp).Row

    For q = 1 To Общее Step 1
        w = Cells(q, 8).Value
        колво = Cells(q, 11).Value

        For e = 1 To колво Step 1
            Cells(w - 1 + e, 2).Value = "+"
        Next e
    Next q
End Sub

Sub iSubtract()
Dim Arr1
Dim Arr2
Dim i As Integer
Dim j As Integer
  Arr1 = Range("A2:B10").Value
  With Worksheets("Лист2")
    Arr2 = .Range("A2:B10").Value
    For i = 1 To UBound(Arr1)
      For j = 1 To UBound(Arr1, 2)
        Arr1(i, j) = Arr1(i, j) - Arr2(i, j)
      Next
    Next
    [A2].Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1
  End With
End Sub

Function VLOOKUP2(Table As Variant, SearchColumnNum As Long, SearchValue As Variant, _
                  N As Long, ResultColumnNum As Long)
    Dim i As Long, iCount As Long
    Select Case TypeName(Table)
    Case "Range"
        For i = 1 To Table.Rows.Count
            If Table.Cells(i, SearchColumnNum) = SearchValue Then
                iCount = iCount + 1
            End If
            If iCount = N Then
                VLOOKUP2 = Table.Cells(i, ResultColumnNum)
                Exit For
            End If
        Next i
    Case "Variant()"
        For i = 1 To UBound(Table)
            If Table(i, 1) = SearchValue Then iCount = iCount + 1
            If iCount = N Then
                VLOOKUP2 = Table(i, ResultColumnNum)
                Exit For
            End If
        Next i
    End Select
End Function

Sub CollectDataFromAllSheets()    
Dim ws As Worksheet
     Set wbCurrent = ActiveWorkbook
    Workbooks.Add
    Set wbReport = ActiveWorkbook
      
    'копируем на итоговый лист шапку таблицы из первого листа
    wbCurrent.Worksheets(1).Range("A1:T1").Copy Destination:=wbReport.Worksheets(1).Range("A1")
      
    'проходим в цикле по всем листам исходного файла
    For Each ws In wbCurrent.Worksheets
      
        'определяем номер последней строки на текущем листе и на листе сборки
        n = wbReport.Worksheets(1).Range("A1").CurrentRegion.Rows.Count
          
        'задаем исходный диапазон, который надо скопировать с каждого листа - любой вариант на выбор:
        ' Set rngData = ws.Range("A2:T20")            'фиксированный диапазон или
     '  Set rngData = ws.UsedRange                 'всё, что есть на листе или
      '  Set rngData = ws.Range("F5").CurrentRegion    'область, начиная от ячейки F5 или
        Set rngData = ws.Range("A2", ws.Range("A2").SpecialCells(xlCellTypeLastCell))    'от А2 и до конца листа
          
        'копируем исходный диапазон и вставляем в итоговую книгу со следующей строки
        rngData.Copy Destination:=wbReport.Worksheets(1).Cells(n + 1, 1)
          
    Next ws
End Sub

 =ИНДЕКС(Main!$DT$4:$EG$4;ПОИСКПОЗ(1;ИНДЕКС((СЧЁТЕСЛИ($L$2:L2;Main!$DT$4:$EG$4)=0)/(Main!$DT$8:$EG$8<>"");0);0))

=ИНДЕКС(Лист1!$C:$C;ПОИСКПОЗ($A2&M$1&$P$1;Лист1!$A:$A&Лист1!$B:$B&Лист1!$D:$D;0);1)
=СУММПРОИЗВ(--($A2=Лист1!$A$2:$A$28);--(N$1=Лист1!$B$2:$B$28);Лист1!$C$2:$C$28)
=ПРОСМОТР(2;1/($A2&M$1&$P$1=Лист1!$A$2:$A$28&Лист1!$B$2:$B$28&Лист1!$D$2:$D$28);Лист1!$C$2:$C$28)

Sub Скрыть()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim LastRow, ST_A() As Variant
Dim ii As Integer
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
ReDim ST_A(LastRow, 1)
ST_A = Range(Cells(1, 1), Cells(1 + LastRow - 1, 1))

For ii = 1 To LastRow
    If ST_A(ii, 1) = 0 Or ST_A(ii, 1) = "" Then
       Rows(ii).Hidden = True
    End If
Next

MsgBox "ГОТОВО"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Function СЦЕПИТЬЕСЛИМН(rngU As Range, ParamArray Conditions()) As String
'rngU - диапазон сцепления
'Conditions() - массив ПАР значений вида: Диапазон_Условий1;Условие1;Диапазон_Условий2;Условие2...Диапазон_УсловийN;УсловиеN, обязательный
'               должен иметь хотя-бы одну пару значений.
'Разделителем найденных уникальных значений является ', ' (запятая с пробелом)
'Все диапазоны должны состоять из одного столбца и иметь равное кол-во строк
Dim cl()
Dim arrFlag() As Boolean
Dim I&, j&
On Error Resume Next
cl = rngU.Value
For I = 1 To UBound(cl)
    ReDim arrFlag(Int(UBound(Conditions) / 2))
    For j = LBound(Conditions) To UBound(Conditions) Step 2
        If rngU.Parent.Cells(rngU(I).Row, Conditions(j).Column).Value Like Conditions(j + 1) Then
            arrFlag(Int(j / 2)) = True
        End If
      If БезПовторов Then
        Dim oDict As Object, sTmpStr
        Set oDict = CreateObject("Scripting.Dictionary")
        sTmpStr = Split(sStr, разделитель)
        On Error Resume Next
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            oDict.Add sTmpStr(li), sTmpStr(li)
        Next li
        sStr = ""
        sTmpStr = oDict.Keys
        For li = LBound(sTmpStr) To UBound(sTmpStr)
            sStr = sStr & IIf(sStr <> "", разделитель, "") & sTmpStr(li)
        Next li
    End If
        
    Next
    If WorksheetFunction.And(arrFlag) = True Then
         
        
        If СЦЕПИТЬЕСЛИМН <> Empty Then
            СЦЕПИТЬЕСЛИМН = СЦЕПИТЬЕСЛИМН & " " & cl(I, 1)
        Else
            СЦЕПИТЬЕСЛИМН = cl(I, 1)
        End If
  
    
    End If
    
Next
End Function

Private Sub Worksheet_Change(ByVal Target As Excel.Range)  
    If Not Intersect(Target, Range("С1:C10")) Is Nothing Then
        If IsNumeric(Target.Value) Then
            Application.EnableEvents = False
            Target.Offset(0, -1).Value = Target.Offset(0, -1).Value + Target.Value
            Application.EnableEvents = True
        End If
    End If
End Sub

Function СЦЕПИТЬУНИКЕСЛИМН(rngU As Range, ParamArray Conditions()) As String
'rngU - диапазон поиска уникальных значений, обязательный
'Conditions() - массив ПАР значений вида: Диапазон_Условий1;Условие1;Диапазон_Условий2;Условие2...Диапазон_УсловийN;УсловиеN, обязательный
'               должен иметь хотя-бы одну пару значений.
'Разделителем найденных уникальных значений является ', ' (запятая с пробелом)
'Все диапазоны должны состоять из одного столбца и иметь равное кол-во строк
Application.Volatile

Dim cl()
Dim arrFlag() As Boolean
Dim I&, j&
On Error Resume Next
cl = rngU.Value
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(cl)
        ReDim arrFlag(Int(UBound(Conditions) / 2))
        For j = LBound(Conditions) To UBound(Conditions) Step 2
            If Cells(rngU(I).Row, Conditions(j).Column).Value Like Conditions(j + 1) Then
                arrFlag(Int(j / 2)) = True
            End If
        Next
        If WorksheetFunction.And(arrFlag) = True Then
            .Add CStr(cl(I, 1)), cl(I, 1)
            If Err = 0 Then
                If СЦЕПИТЬУНИКЕСЛИМН <> Empty Then
                    СЦЕПИТЬУНИКЕСЛИМН = СЦЕПИТЬУНИКЕСЛИМН & ", " & cl(I, 1)
                Else
                    СЦЕПИТЬУНИКЕСЛИМН = cl(I, 1)
                End If
            Else
                Err.Clear
            End If
        End If
    Next
End With
End Function