Оптимизация кода - VBA (48931)

Формулировка задачи:

Есть код для копирования листа в созданную книгу, листы копируются с системной датой. Можно ли как то уменьшить код?

Sub копиялиста()
Application.ScreenUpdating = False
Dim NameBook, NameBookKop, ActiveDir, FoldDir, NameList, D As String
Dim LastName
Dim L
    D = Format(Date, "dd.mm.yyyy") ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Дата сохранения
    NameList = "Дневная сводка" '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Имя листа для копии
    NameBookKop = "Копия листов тест.xlsm" ''''''''''''''''''''''''''''''''''''''''''''''''''''''''Имя файла в который будет копироваться
    NameBook = ActiveWorkbook.Name ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Имя активной книги
    ActiveDir = ActiveWorkbook.Path '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''дирректория активного файла или указать свой путь "C:"
    FoldDir = ActiveDir & "\" & NameBookKop ''''''''''''''''''''''''''''''''''''''''''''''полный путь к файлу для открытия
If MsgBox("Сохранить дневную сводку в архив?", vbOKCancel, "Внимание!") = vbOK Then
On Error Resume Next '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''если файл не открыт то идем дальше, если открыт то закрываем
    Windows(NameBookKop).Close
    Workbooks.Open Filename:=FoldDir ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''открываем файл для копирования
        Windows(NameBookKop).Activate                                              'выделяем открытую книгу для определения последнего листа
            LastName = Application.Workbooks.Item(ActiveWorkbook.Name).Sheets.Count        'поиск номера последнего листа
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''Проверка наличия листа, если лист не найден - делаем копию листа
            L = 0
For Each Sheet In Worksheets
If Sheet.Name = NameList & " " & D Then
L = 1
        If MsgBox("Лист уже сохранен! Удалить его? После удаления, данные вернуть не возможно!!!", vbOKCancel, "Внимание!") = vbOK Then
                Application.DisplayAlerts = False ' выключаем все предупреждения
             Sheets(NameList & " " & D).Delete
             ActiveWorkbook.Save
             ActiveWorkbook.Close
                Application.DisplayAlerts = True 'обратно включаем предупреждения.
                Workbooks(NameBook).Sheets("Главная").CommandButton1.Caption = "Лист " & NameList & " " & D & " был удален! " 'пишем в кнопке
        Workbooks(NameBook).Sheets("Главная").CommandButton1.BackColor = RGB(255, 0, 0) 'расскрашиваем кнопку красным
    MsgBox "Лист " & NameList & " " & D & " был удален! Сделайте копию листа!", , "Внимание!"
        End If
End If
Next
        
If L = 0 Then
Windows(NameBook).Activate
        Sheets(NameList).Select
            Sheets(NameList).Copy After:=Workbooks(NameBookKop).Sheets(LastName)   'копия листа
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Windows(NameBookKop).Activate
        LastName = Str(Application.Workbooks.Item(ActiveWorkbook.Name).Sheets.Count) 'поиск номера последнего листа
        Sheets(LastName).Activate
ActiveSheet.Name = NameList & " " & D 'переименование последнего сохраненного листа
        ActiveWorkbook.Save
    MsgBox "Данные успешно сохранены!", , "Внимание!"
    Workbooks(NameBook).Sheets("Главная").CommandButton1.Caption = "Лист сохранен!"     'пишем в кнопке
        Workbooks(NameBook).Sheets("Главная").CommandButton1.BackColor = RGB(0, 255, 0) 'расскрашиваем кнопку зеленым
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Windows(NameBookKop).Close
        Windows(NameBook).Activate
        Sheets("Главная").Select
Application.ScreenUpdating = True
End If
End Sub

Решение задачи: «Оптимизация кода»

textual
                            Листинг программы 
                        

                            Sub копиялиста()
  Dim NameBookKop$, NameList$, newName$
  Dim Sh As Worksheet, ActBook As Workbook
    
    Set ActBook = ActiveWorkbook
    NameList = "Дневная сводка"                         ' Имя листа для копии
    newName = NameList & Format(Date, " dd.mm.yyyy")    ' новое наименование листа
    NameBookKop = "Копия листов тест.xlsm"              ' Имя файла в который будет копироваться
 
    If MsgBox("Сохранить дневную сводку в архив?", vbOKCancel, "Внимание!") <> vbOK Then Exit Sub
    Application.ScreenUpdating = False
    On Error Resume Next
    Workbooks(NameBookKop).Close ' если файл не открыт то идем дальше, если открыт то закрываем
    With Workbooks.Open(Filename:=ActBook.Path & "\" & NameBookKop) 'открываем файл для копирования
        Set Sh = .Sheets(newName)
        On Error GoTo 0
        If Not Sh Is Nothing Then
            If MsgBox("Лист уже сохранен! Удалить его? После удаления, данные вернуть не возможно!!!", _
                    vbOKCancel + vbExclamation, "Внимание!") = vbOK Then
                Application.DisplayAlerts = False ' выключаем все предупреждения
                Sh.Delete
                Application.DisplayAlerts = True 'обратно включаем предупреждения.
                .Close True
                With ActBook.Sheets("Главная").CommandButton1
                    .Caption = "Лист " & newName & " был удален! " 'пишем в кнопке
                    .BackColor = RGB(255, 0, 0) 'расскрашиваем кнопку красным
                    MsgBox "Лист " & newName & " был удален! Сделайте копию листа!", vbInformation, "Внимание!"
                End With
            End If
        Else
            ActBook.Sheets(NameList).Copy After:=.Sheets(.Sheets.Count) 'копия листа
            .Sheets(.Sheets.Count).Name = newName
            .Close True
            MsgBox "Данные успешно сохранены!", vbInformation, "Внимание!"
            With Sheets("Главная").CommandButton1
                .Caption = "Лист сохранен!"     'пишем в кнопке
                .BackColor = RGB(0, 255, 0) 'расскрашиваем кнопку зеленым
            End With
        End If
    End With
    Application.ScreenUpdating = True
End Sub
                        