Sub CopyLists()
    Dim wsSh As Worksheet, NewWb As Workbook, asArr(), li As Long, DateString As String
    Dim iPath As String, iVBComponent As Object ', MyPassword As String

    Application.ScreenUpdating = False
    
    DateString = Format(Sheets("Лист3").Range("A1").Value, "yy_mm_dd")
    Set NewWb = ActiveWorkbook
    Set iVBComponents = NewWb.VBProject.VBComponents
    
    For Each wsSh In Worksheets
        If wsSh.Visible <> -1 Then ReDim Preserve asArr(li): asArr(li) = wsSh.Name: li = li + 1: wsSh.Visible = xlSheetVisible
    Next wsSh
    Sheets(Array("Лист1", "Лист2")).Copy

    'Удаление макросов из созданной книги
    For Each iVBComponent In iVBComponents
        Select Case iVBComponent.Type
        Case 1 To 3: iVBComponents.Remove iVBComponent
        Case 100
            With iVBComponent.CodeModule
                .DeleteLines 1, .CountOfLines
            End With
        End Select
    Next
    Set iVBComponents = Nothing

    'MyPassword = "******"    'Пароль для защиты листа
    For Each wsSh In NewWb.Worksheets
        With wsSh
            .Visible = True
            .UsedRange.Value = .UsedRange.Value
            .Cells.Locked = True
            .Cells.FormulaHidden = True
            '.Protect Password:=MyPassword, DrawingObjects:=True, Contents:=True, Scenarios:=True
            .EnableSelection = xlNoSelection
        End With
    Next
        
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Путь сохранения"
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        iPath = .SelectedItems(1) & Application.PathSeparator
    End With
    
    NewWb.SaveAs Filename:=iPath & "Копия_" & DateString, FileFormat:=xlOpenXMLWorkbook
    NewWb.Close
    Application.ScreenUpdating = True
    'ThisWorkbook.Close SaveChanges:=False
    MsgBox "Копия_" & DateString & " сохранена в папку: " & iPath, vbInformation, "Завершено"
End Sub

Sub CopyLists()
    Dim wsSh As Worksheet, NewWb As Workbook, asArr(), li As Long, DateString As String
    Dim MyPassword As String, iPath As String
  
    DateString = Format(Sheets("Лист3").Range("A1").Value, "yy_mm_dd")
    Application.ScreenUpdating = False
    For Each wsSh In Worksheets
        If wsSh.Visible <> -1 Then ReDim Preserve asArr(li): asArr(li) = wsSh.Name: li = li + 1: wsSh.Visible = xlSheetVisible
    Next wsSh
    Sheets(Array("Лист1", "Лист2")).Copy
    Set NewWb = ActiveWorkbook
    For Each wsSh In NewWb.Worksheets
        With wsSh
            .Visible = True
            .UsedRange.Value = .UsedRange.Value
            .Cells.Locked = True
            .Cells.FormulaHidden = True
            .EnableSelection = xlNoSelection
        End With
    Next
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Путь сохранения"
        .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        iPath = .SelectedItems(1) & Application.PathSeparator
    End With
    
    NewWb.SaveAs Filename:=iPath & "Копия_" & DateString & ".xls"
    NewWb.Close
    Application.ScreenUpdating = True
    'ThisWorkbook.Close SaveChanges:=False
    MsgBox "Копия_" & DateString & " сохранена в папку: " & iPath, vbInformation, "Завершено"
End Sub