Код сохраняет мой файл много раз вместо одного

Question

Я получил несколько кодов из inte rnet для автоматического сохранения моего файла в указанное c время, создавая новый файл с датой и временем.

Вместо одного создаются случайные файлы каждую секунду. Вчера у меня было создано 200 файлов. У меня есть несколько кодов для сохранения, один после каждого действия, выполненного в рабочей книге, один для предотвращения закрытия файла и один для копирования с именем даты и времени.

Я знаю, что у меня есть множество кодов сохранения но не знаю, какой удалить, чтобы прекратить сохранение файла n раз в день.

Код в моей рабочей книге:

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    'If Weekday(Date) = 5 Then
    Application.OnTime TimeValue("23:30:00"), "copySheets"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    'Step 1: Check to see if cell C7 is blank
    If sheets("Trailers").Range("Z1").Value = "" Then
    'Step 2: If cell is blank, cancel the close and tell user
        Cancel = True
        MsgBox "NOPE !!!"
    'Step 3: If cell is not blank, save and close
    Else
        ActiveWorkbook.Close SaveChanges:=True
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    Application.DisplayAlerts = True
End Sub

Private Sub Workbook_WindowResize(ByVal Wn As Window)
    Wn.WindowState = xlMaximized
    ActiveWindow.EnableResize = False
End Sub

Код в моем модуле для создания нового файла с датой и временем.

Sub copySheets() 

    Dim wkb As Excel.Workbook
    Dim newWkb As Excel.Workbook
    Dim wks As Excel.Worksheet
    Dim newWks As Excel.Worksheet
    Dim sheets As Variant
    Dim varName As Variant
    '------------------------------------------------------------
     'Clearing all the values every Saturday
     'If Weekday(Date) = 7 Then
     'Worksheets("Trailers").Range("A3:D307").ClearContents
     'Worksheets("Trailers").Range("G3:G307").ClearContents
     ' Worksheets("Trailers").Range("J3:J307").ClearContents
      ' Worksheets("Trailers").Range("M3:M307").ClearContents
       ' Worksheets("Trailers").Range("P3:P307").ClearContents
       ' End If
       ' Application.OnTime TimeValue("23:30:00"), "copySheets"
    'Define the names of worksheets to be copied.
    sheets = VBA.Array("Trailers")

    'Create reference to the current Excel workbook and to the destination workbook.
    Set wkb = Excel.ThisWorkbook
    Set newWkb = Excel.Workbooks.Add

    For Each varName In sheets

        'Clear reference to the [wks] variable.
        Set wks = Nothing

        'Check if there is a worksheet with such name.
        On Error Resume Next
        Set wks = wkb.Worksheets(VBA.CStr(varName))
        On Error GoTo 0

        'If worksheet with such name is not found, those instructions are skipped.
        If Not wks Is Nothing Then
            'Copy this worksheet to a new workbook.
            Call wks.Copy(newWkb.Worksheets(1))

            'Get the reference to the copy of this worksheet and paste
            'all its content as values.
            Set newWks = newWkb.Worksheets(wks.Name)

        End If

    Next
    'ActiveWorkbook.SaveCopyAs Filename:=ThisWorkbook.Path & Format(Now(), "YYYYMMDD") & " Forecasting" & ".xlsm"
    Application.DisplayAlerts = False
    ActiveWorkbook.ActiveSheet.Name = "report"
    ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "report " & Format(CStr(Now()), "dd-mmm (hh.mm.ss AM/PM)") & ".xlsx"
    Application.DisplayAlerts = False
    ActiveWorkbook.Close SaveChanges:=True

End Sub

Answer 1

На данный момент мой код Workbook выглядит следующим образом:

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
 'If Weekday(Date) = 5 Then
 Application.OnTime TimeValue("23:30:00"), "copySheets"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'Step 1: Check to see if cell C7 is blank
If sheets("Trailers").Range("Z1").Value = "" Then
'Step 2: If cell is blank, cancel the close and tell user
    Cancel = True
    MsgBox "NOPE !!!"
'Step 3: If cell is not blank, save and close
End If
End Sub




Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.DisplayAlerts = True
End Sub

И мой код модуля Sub copySheets () остается прежним.

Answer 2

Ваша проблема, скорее всего, такова:

ActiveWorkbook.Close

в вашем Workbook_BeforeClose подпрограмме.

Способ работы подпрограммы перед закрытием состоит в том, что она запускает код в подпрограмме, а затем закрывается автоматически.

Проблема в том, что в подпрограмме вы также указываете закрыть ее снова . Это означает, что он заново запустит другую последовательность закрытия, снова запустит сабвуфер, снова встретится с линией закрытия и ... У вас есть повторяющаяся l oop. Если вы замените Activeworkbook.Close на Activeworkbook.Save, это обеспечит сохранение ваших изменений, и рабочая книга будет автоматически закрыта в конце подпункта.

Соответствующий ответ