Sub Расклад_по_классам()
Dim LastRow As Long, Rw As Long
LastRow = Worksheets("РАСЧЕТ").Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("Лист1")
        Rw = .Cells(Rows.Count, 5).End(xlUp).Row + 1
        For i = 2 To LastRow
             If Worksheets("РАСЧЕТ").Cells(i, 1) = "1А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "1Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "2А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "2Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "3А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "3Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "4А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "4Б" Then
                .Cells(Rw, 5).Value = Cells(i, 2)
                Rw = Rw + 1
            End If
        Next
          Rw = .Cells(Rows.Count, 8).End(xlUp).Row + 1
        For i = 2 To LastRow
             If Worksheets("РАСЧЕТ").Cells(i, 1) = "5А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "5Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "6А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "6Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "7А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "7Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "8А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "8Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "9А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "9Б" Then
                .Cells(Rw, 8).Value = Cells(i, 2)
                Rw = Rw + 1
            End If
        Next
         Rw = .Cells(Rows.Count, 11).End(xlUp).Row + 1
        For i = 2 To LastRow
             If Worksheets("РАСЧЕТ").Cells(i, 1) = "10А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "10Б" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "11А" Or _
             Worksheets("РАСЧЕТ").Cells(i, 1) = "11Б" Then
                .Cells(Rw, 11).Value = Cells(i, 2)
                Rw = Rw + 1
            End If
        Next
    End With
End Sub 

Sub Микро_на_сдачу()
 
    Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"        
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*№*.xlsm")
    Do While sFiles <> ""
        'открываем книгу
        Workbooks.Open sFolder & sFiles
        'действия с файлом
    'Заполняем формулы
    Worksheets("Микроучасток").Range("B2").Value = "ДАТА ОТЧЕТА"
    Worksheets("Микроучасток").Range("B3").Value = ThisWorkbook.Sheets(1).Range("K3")  'СОБСТВЕННО САМА ДАТА ОТЧЕТА
    Worksheets("Микроучасток").Range("B3").NumberFormat = "m/d/yyyy"
    'Закончили с формулами
 
        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close True 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
     
End Sub

Sub Подготовка_Микро_уч()
'
' Подготовка_Микро_уч Макрос
'
    Sheets("Приложение № 7 ").Select
    ActiveSheet.Unprotect
    Sheets("Приложение № 3 ").Select
    ActiveSheet.Unprotect
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Sheets("Приложение № 7 ").Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1").Select
    Application.DisplayAlerts = False
    Sheets("Техническая часть").Delete
    Sheets("Вводные").Visible = -1
    Sheets("Вводные").Delete
    Sheets("WARNING").Visible = -1
    Sheets("WARNING").Delete
    Application.DisplayAlerts = True
    Sheets("Титульный").Select
    Range("A1").Select
    Sheets("Микроучасток").Select
    Range("Таблица1[[#Headers],[№ п.п]]").Select
    ActiveWindow.Zoom = 100
    Dim Sh As Worksheet
    Dim iObj As ListObject
    For Each Sh In Worksheets
    For Each iObj In Sh.ListObjects
        iObj.Unlist
    Next
    Next
    Dim oVBComponent As Object, lCountLines As Long
    Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("ЭтаКнига")
    With oVBComponent
        lCountLines = .CodeModule.CountOfLines
        .CodeModule.DeleteLines 1, lCountLines
    End With
    Set oVBComponent = Nothing
    Dim n As Variant
    For Each n In ActiveWorkbook.Names:
    On Error Resume Next
    n.Delete:
    Next
'Call Macro2
End Sub

Sub Macro2()
   ChDir "D:\Users\user\Desktop\Новая папка"
    ActiveWorkbook.SaveAs FileName:= _
        "D:\Users\user\Desktop\Новая папка\" & ActiveWorkbook.Name & ".xlsx" _
        , FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Application.DisplayAlerts = False
        Application.Quit       
End Sub

Sub Delete_Macroses_In_One_Comp()
    Dim oVBComponent As Object, lCountLines As Long
    Set oVBComponent = ActiveWorkbook.VBProject.VBComponents("ЭтаКнига")
    With oVBComponent
        lCountLines = .CodeModule.CountOfLines
        .CodeModule.DeleteLines 1, lCountLines
    End With
    Set oVBComponent = Nothing
End Sub

Sub Макрос1()
    Selection.AutoFilter
    Cells.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
        :=xlBetween
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
End Sub

Sub CombineWorkbooks()
    Dim FilesToOpen
    Dim x As Integer
  
    Application.ScreenUpdating = False  'отключаем обновление экрана для скорости
      
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="All files (*.*), *.*", _
      MultiSelect:=True, Title:="Files to Merge")
  
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбрано ни одного файла!"
        Exit Sub
    End If
      
    'проходим по всем выбранным файлам
    x = 1
    While x <= UBound(FilesToOpen)
        Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
        Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        importWB.Close savechanges:=False
        x = x + 1
    Wend
  
    Application.ScreenUpdating = True
   
End Sub

Sub Удаление_таблицы()
    Range("C12:L" & Cells(Rows.Count, 3).End(xlUp).Row).Delete
End Sub