Kill Addr & "Файл без макросов 2007.xlsx

Sub Мяу()
    Dim sfName1$, sfName2$
    Dim sh As Worksheet, nm As Name
    sfName1 = ThisWorkbook.FullName
    sfName1 = Replace(sfName1, "xlsm", "xlsx")
    sfName2 = Left(sfName1, Len(sfName1) - 1)
    Application.ScreenUpdating = False
    Application.CopyObjectsWithCells = False
    Sheets(Array(1, 3)).Copy
    For Each sh In ActiveWorkbook.Worksheets
        sh.UsedRange.Value = sh.UsedRange.Value
    Next
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs sfName1, 51
    ActiveWorkbook.Close False
    Workbooks.Open sfName1
    ActiveWorkbook.SaveAs sfName2, 56
    ActiveWorkbook.Close False
    Kill sfName1
    Application.DisplayAlerts = True
    Application.CopyObjectsWithCells = True

End Sub

Sub кол_вх()
Dim s As String, fldr As String
fldr = "D:\111\"
s = Dir(fldr & "*.xls")
Do While s <> ""
    With Workbooks.Open(fldr & s)
    Dim sfName1$, sfName2$
    Dim sh As Worksheet, nm As Name
    sfName1 = ActiveWorkbook.FullName
    sfName1 = Replace(sfName1, "xlsm", "xlsx")
    sfName2 = Left(sfName1, Len(sfName1) - 1)
    Application.ScreenUpdating = False
    Application.CopyObjectsWithCells = False
    ActiveWorkbook.Sheets(Array(1, 2, 3, 4)).Copy
    For Each sh In ActiveWorkbook.Worksheets
        sh.UsedRange.Value = sh.UsedRange.Value
    Next
    For Each nm In ActiveWorkbook.Names
        nm.Delete
    Next
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs sfName1, 51
    ActiveWorkbook.Close False
    Workbooks.Open sfName1
    ActiveWorkbook.SaveAs sfName2, 56
    ActiveWorkbook.Close False
    Kill sfName1
    Application.DisplayAlerts = True
    Application.CopyObjectsWithCells = True
        .Close 0
    End With
    s = Dir
Loop
End Sub

Sub Микро_на_сдачу()
    Dim sFolder As String, sFiles As String
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    With UserForm1
        .Show 0
        .Label1.Caption = "Работаем..."
        .Repaint
        For i = 1 To 100000000
        Next
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*№*.xlsm")
    Do While sFiles <> ""
        'открываем книгу
        Workbooks.Open sFolder & sFiles
        'действия с файлом         
        Sheets("Приложение № 7 ").Select
        ActiveSheet.Unprotect 'снимаем блокировку с листа
        Cells.Select 'выделяем весь лист
        Selection.Copy 'Копируем
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False ' вставляем в лист значения за место формул
        Range("A1").Select
        Sheets("Приложение № 3 ").Select
        ActiveSheet.Unprotect
        Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Range("A1").Select
        Sheets("Титульный").Select
        Range("A1").Select
        Sheets("Микроучасток").Select
        Range("Таблица1[[#Headers],[№ п.п]]").Select
        ActiveWindow.Zoom = 100
        'Преорбазуем таблицы в диапазоны
        Dim sh1 As Worksheet
        Dim iObj As ListObject
        For Each sh1 In Worksheets
        For Each iObj In sh1.ListObjects
            iObj.Unlist
        Next
        Next
        'Макрос сохранения книги со старым именем и новым расширением xlsx
        Dim sfName1$
        Dim sh As Worksheet, nm As Name
        sfName1 = ActiveWorkbook.FullName
        sfName1 = Replace(sfName1, "xlsm", "xlsx")
        Application.ScreenUpdating = False
        Application.CopyObjectsWithCells = False
        ActiveWorkbook.Sheets(Array(1, 2, 3, 5)).Copy
        'Преобразование формул в значения, не всегда работает корректно, оставил просто так.
        For Each sh In ActiveWorkbook.Worksheets
            sh.UsedRange.Value = sh.UsedRange.Value
        Next
        'Удаление именнованных диапазонов показать по ctrl+F3
         For Each n In ActiveWorkbook.Names:
        On Error Resume Next
        n.Delete:
        Next
        
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs sfName1, 51
        ActiveWorkbook.Close False
        Application.DisplayAlerts = True
        Application.CopyObjectsWithCells = True
    
        'Закрываем книгу с сохранением изменений
        ActiveWorkbook.Close False 'если поставить False - книга будет закрыта без сохранения
        sFiles = Dir
    Loop
    'возвращаем ранее отключенное обновление экрана
    Application.ScreenUpdating = True
    .Label1.Caption = "ГОТОВО"
    End With
End Sub