Sub Выбор_файла()
    Dim sFileName As String, sNewFileName As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Bыбор файла и обработки его макросом"
        .ButtonName = "Выбрать этот файл"
        
        
        .AllowMultiSelect = False
        .InitialFileName = ""
        If .Show = -1 Then
            sFileName = .SelectedItems(1) 'имя файла для перемещения
            Workbooks.Open .SelectedItems(1) 'имя файла для копирования
            
            ' Начало редактирование выбранного файла
        Rows("1:1").Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With
  ' Начало редактирование выбранного файла

        Rows("2:2").Select
    Selection.Delete Shift:=xlUp
        Cells.Select
        With Selection
        .VerticalAlignment = xlTop
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlLTR
        .MergeCells = False
    End With
    
    Selection.UnMerge
Columns(2).Delete
Columns(3).Delete
Columns(4).Delete
Columns(4).Delete
Columns(5).Delete
Columns(5).Delete
Columns(6).Delete
Columns(6).Delete
    'конец


    Range("A3:I1000").Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("B4:B38") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A3:I1000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    'конец
        Columns("A:E").Select
    Selection.Copy
    Windows("Питание2.xlsm").Activate
    Range("B1").Select
    ActiveSheet.Paste
    'начало закрытия неактивных книг
        Application.DisplayAlerts = False
    Dim ActiveWB: ActiveWB = ThisWorkbook.Name

    For Each wb In Application.Workbooks
        If (wb.Name <> ActiveWB) Then
            wb.Close
        End If
    Next 'конец закрытия неактивных книг
    
    ' начало фильтрации
     Columns("F:F").Select
Selection.Replace What:="КомплекснОбед", Replacement:="обед", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Selection.Replace What:="КомплекснУжин", Replacement:="ужин", LookAt:=xlPart, _
               SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Selection.Replace What:="Ужин ночь", Replacement:="ночной ужин", LookAt:=xlPart, _
               SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        
   Columns("B:B").ColumnWidth = 10.67
    Columns("C:F").Select
    Columns("C:F").EntireColumn.AutoFit
        Sheets("Питание Сотрудников").Select
    Rows("8").Select
    Sheets("Сотрудники").Select
    Range("B2").Select
    'конец
            
            
        Else
            Exit Sub
        End If
    End With
    '---выбор папки---
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Куда переместить файл"
        .ButtonName = "Выбрать эту папку"
        .AllowMultiSelect = False
        .InitialFileName = ""
        If .Show = -1 Then
            sNewFileName = .SelectedItems(1) 'имя файла для перемещения
        Else
            Exit Sub
        End If
    End With
     
    sNewFileName = sNewFileName & Application.PathSeparator & Right(sFileName, Len(sFileName) - InStrRev(sFileName, "\"))
    Name sFileName As sNewFileName 'перемещаем файл
    MsgBox "Файл " & Right(sFileName, Len(sFileName) - InStrRev(sFileName, "\")) & " перемещен", vbInformation, "Сообщение"
End Sub