Sub CopyLists()
    Dim wsSh As Worksheet, NewWb As Workbook, DateString As String
    Dim iPath As String  ', MyPassword As String

    Application.ScreenUpdating = False

    DateString = Format(Sheets("Лист3").Range("A1").Value, "yy_mm_dd")


    For Each wsSh In ThisWorkbook.Worksheets
        If wsSh.Visible <> -1 Then wsSh.Visible = xlSheetVisible
    Next wsSh

    With Application
        .EnableEvents = False
        .DisplayAlerts = False
        ThisWorkbook.Sheets(Array("Лист1", "Лист2")).Copy
        .EnableEvents = True
    End With
    Set NewWb = ActiveWorkbook


    '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 & ".xlsx"
    NewWb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    'ThisWorkbook.Close SaveChanges:=False
    MsgBox "Копия_" & DateString & " сохранена в папку: " & iPath, vbInformation, "Завершено"
End Sub