wsArr = Array("лист1", "лист2", "лист3", "лист4", "лист5", "лист6")

For Each wsName In wsArr

    Set ws = Worksheets(wsName)

    iLastRow = ws.Cells(Rows.Count, 18).End(xlUp).ROW
    'ws.Range("AA4", Cells(iLastRow, 27)).ClearContents
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each vItem In ws.Range("A4", Cells(iLastRow, 1)).Value
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li, 1) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    If li Then ws.Cells(4, 27).Resize(li).Value = avArr

Next
 

 Worksheets("1").Cells(x, y).FormulaArray = "=SUMPRODUCT('2'!R5C:R9C,TRANSPOSE('3'!RC4:RC8))-VLOOKUP(RC4,'4'!C24:C43,MATCH(R4C,'4'!R4C25:R4C43,0)+1,FALSE)" & _
          "+IF('4'!RC[-1]>0,0,IF((RC[-1]-'5'!RC[-1])<0,RC[-1]-'5'!RC[-1],0))"

Worksheets("1").Cells(x, y).FormulaArray = "=SUMPRODUCT('2'!R5C:R9C,TRANSPOSE('3'!RC4:RC8))-VLOOKUP(RC4,'4'!C24:C43,MATCH(R4C,'4'!R4C25:R4C43,0)+1,FALSE)"
 

    ActiveSheet.Range(Cells(5, i), Cells(9, i)).ClearContents    
    bar.Start    
    SolverReset    
    SolverOk SetCell:=Cells(1, i), MaxMinVal:=1, ValueOf:=0, ByChange:=Range(Cells(5, i), Cells(9, i)), _
    Engine:=1, EngineDesc:="GRG Nonlinear"
   
    SolverAdd CellRef:=Range(Cells(5, i), Cells(9, i)), Relation:=4, FormulaText:="öåëîå"   
    SolverAdd CellRef:=Cells(12, i), Relation:=3, FormulaText:="0"   
    SolverAdd CellRef:=Range(Cells(5, i), Cells(9, i)), Relation:=3, FormulaText:="0"  
    SolverAdd CellRef:=Cells(5, i), Relation:=P1, FormulaText:=TextBox2.Value
       SolverAdd CellRef:=Cells(6, i), Relation:=P2, FormulaText:=TextBox3.Value  
    SolverAdd CellRef:=Cells(7, i), Relation:=P3, FormulaText:=TextBox4.Value  
    SolverAdd CellRef:=Cells(8, i), Relation:=P4, FormulaText:=TextBox5.Value
      SolverAdd CellRef:=Cells(9, i), Relation:=P5, FormulaText:=TextBox6.Value  
    SolverOk SetCell:=Cells(1, i), MaxMinVal:=1, ValueOf:=0, ByChange:=Range(Cells(5, i), Cells(9, i)), _
    Engine:=1, EngineDesc:="GRG Nonlinear"
    SolverOk SetCell:=Cells(1, i), MaxMinVal:=1, ValueOf:=0, ByChange:=Range(Cells(5, i), Cells(9, i)), _
    Engine:=1, EngineDesc:="GRG Nonlinear"
       
    bar.Update           
    SolverSolve True  
    Set bar = Nothing

bar.Update

Sub Ìàò_óðîâåíü1()
Dim iLastRow1 As Long
Dim iLastRow2 As Long
Dim iLastRow3 As Long
Dim iLastRow4 As Long
Dim j As Long

    lLastCol = Cells(4, Columns.Count).End(xlToLeft).Column
    Range(Cells(4, 4), Cells(4, lLastCol)).ClearContents
    lLastCol = Cells(4, Columns.Count).End(xlToLeft).Column + 1
    
    iLastRow1 = Cells(Rows.Count, 3).End(xlUp).Row
    Range(Cells(5, 1), Cells(iLastRow1, 1)).ClearContents
    Range(Cells(5, 2), Cells(iLastRow1, 2)).ClearContents
    Range(Cells(5, 3), Cells(iLastRow1, 3)).ClearContents
    iLastRow1 = Cells(Rows.Count, 3).End(xlUp).Row + 1
    
   For Each wsName In Array("Кордон", "Крис", "МБС", "Крис_2003", "Кордон_С")
             
        Set ws = Worksheets(wsName)
        
        iLastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
        For j = 3 To iLastRow2
                If Not IsEmpty(.Cells(j, 5)) Then
                  If .Cells(j, 19) = "полуфабрикат" Or .Cells(j, 19) = "продукция" Then
                        Cells(4, lLastCol + 2) = .Cells(j, 5)
                        lLastCol = lLastCol + 1
                  End If
                End If
        Next
       
        iLastRow4 = .Cells(.Rows.Count, 2).End(xlUp).Row
        For j = 3 To iLastRow4
                If Not IsEmpty(.Cells(j, 6)) Then
                        Cells(iLastRow1 + 3, 1) = .Cells(j, 6)    
                        Cells(iLastRow1 + 3, 2) = .Cells(j, 19)  
                        iLastRow3 = iLastRow1 + 1
                End If
        Next
    Next aSheet


    
End Sub
 

Sub Ìàò_óðîâåíü1()
Dim iLastRow1 As Long
Dim iLastRow2 As Long
Dim iLastRow3 As Long
Dim iLastRow4 As Long
Dim j As Long

    iLastRow1 = Cells(Rows.Count, 3).End(xlUp).Row
    Range(Cells(5, 1), Cells(iLastRow1, 1)).ClearContents
    iLastRow1 = Cells(Rows.Count, 3).End(xlUp).Row + 1
    
    iLastRow3 = Cells(Rows.Count, 3).End(xlUp).Row
    Range(Cells(5, 1), Cells(iLastRow3, 1)).ClearContents
    iLastRow3 = Cells(Rows.Count, 3).End(xlUp).Row + 1
    
    With Sheets("товар5")
        iLastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
        For j = 3 To iLastRow2
                If Not IsEmpty(.Cells(j, 6)) Then
                  If .Cells(j, 19) = "Полуфабрикат" Or .Cells(j, 19) = "Продукция" Then
                        Cells(4, iLastRow1 + 2) = .Cells(j, 6)
                        iLastRow1 = iLastRow1 + 1
                  End If
                End If
        Next
    End With
    
    With Sheets("товар5")
        iLastRow4 = .Cells(.Rows.Count, 2).End(xlUp).Row
        For j = 3 To iLastRow4
                If Not IsEmpty(.Cells(j, 7)) Then
                        Cells(iLastRow3 + 3, 1) = .Cells(j, 7)    
                        Cells(iLastRow3 + 3, 2) = .Cells(j, 19)   'тип
                        iLastRow3 = iLastRow3 + 1
                End If
        Next
    End With 
.......
end sub

    Range("R11C5:R20C5").Select
    Selection.FormulaArray = "=[01.02.2014.xls]Сайдинг_день!R105C19:R113C19"
    Range("R22C5:R31C5").Select
    Selection.FormulaArray = "=[01.02.2014.xls]Сайдинг_день!R105C20:R113C20"
    
    Range("R11C6:R20C6").Select
    Selection.FormulaArray = "=[01.02.2014.xls]Сайдинг_ночь!R105C19:R113C19"
    Range("R22C6:R31C6").Select
    Selection.FormulaArray = "=[01.02.2014.xls]Сайдинг_ночь!R105C20:R113C20"
 

Private Sub Worksheet_Activate()
    Dim ra As Range, delra As Range
    
    
    скрыть = Array("скрыть")

    For Each ra In ActiveSheet.UsedRange.Rows
       For Each word In скрыть
           If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then
               If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
            End If
        Next word
    Next
    
   If Not delra Is Nothing Then delra.EntireRow.Hidden = True
End Sub