Sub Sbor()
Dim Sht As Worksheet
Dim iLastRow As Long
Dim iLR As Long
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A5:K" & iLastRow).EntireRow.Delete
    For Each Sht In Worksheets
    If Sht.Name <> "Обобщенка" And Sht.Name <> "123" Then
        With Sht
        iLR = .Cells(.Rows.Count, 1).End(xlUp).Row
        iLastRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Range(.Cells(2, "A"), .Cells(iLR, "K")).Copy Cells(iLastRow, 1)
        End With
    End If
    Next
End Sub

Sub MacroCollector()
Dim LastRow As Long, i As Long, n As Long, Arr, Uniq As New Collection, x As Long, Material
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range(Cells(2, 1), Cells(LastRow + 1, 1)).Clear
    For n = 1 To Sheets.Count
        With Sheets(n)
            If .Name <> ActiveSheet.Name Then
                LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = 2 To LastRow
                    On Error Resume Next
                    If .Cells(i, 1).Interior.ColorIndex = 40 Then Uniq.Add .Cells(i, 2), CStr(.Cells(i, 2))
                Next
            End If
        End With
    Next
    ReDim Arr(1 To Uniq.Count, 1 To 1)
    For Each Material In Uniq
        x = x + 1
        Arr(x, 1) = Material
    Next
    Range("A2").Resize(x, 1).Value = Arr
    Application.ScreenUpdating = True
End Sub

Sub Листы()
Dim Sht As Worksheet
    For Each Sht In Worksheets
        If Sht.Name <> "Обобщенка" And Sht.Name <> "Заявка" And Sht.Name <> "Данные" Then
            MsgBox Sht.Name
        End If
    Next
End Sub

Sub MacroCollector()
    Dim LastRow As Long, i As Long, n As Long, arr As Variant, Uniq As New Collection, x As Long, Material As Variant
    Dim yy As Long
    Dim xx As Long
    Application.ScreenUpdating = False
    Dim rr As Range
    On Error Resume Next
    Set rr = ActiveSheet.ListObjects(1).DataBodyRange
    On Error GoTo 0
    If rr Is Nothing Then
        Set rr = Cells(5, 1)
    Else
        ActiveSheet.ListObjects(1).Resize ActiveSheet.ListObjects(1).Range.Rows(1).Resize(2)
    End If
      
    LastRow = Cells(Rows.Count, rr.Column).End(xlUp).Row
    Range(Cells(rr.Row, rr.Column), Cells(LastRow + 1, rr.Column)).EntireRow.ClearContents
    yy = rr.Row
    For n = 1 To Sheets.Count
        With Sheets(n)
            If .Name <> ActiveSheet.Name Then
                LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
                For i = 2 To LastRow
                    If Not IsEmpty(.Cells(i, 2).Value) Then
                        If .Cells(i, 1).Interior.ColorIndex = 40 Then
                            arr = .Cells(i, 1).Resize(1, .UsedRange.Columns.Count - 1)
                            Cells(yy, rr.Column).Resize(1, UBound(arr, 2)).Value = arr
'                            For xx = 2 To 4
'                    Cells(yy, rr.Column + xx - 2).Value = .Cells(i, xx)
'                            Next
                            yy = yy + 1
                        End If
                    End If
                Next
            End If
        End With
    Next
    Application.ScreenUpdating = True
End Sub