Блог

Главная - Вопросы по программированию - Файл Excel продолжает открывать даже приложение.График включения выключен

Файл Excel продолжает открывать даже приложение.График включения выключен

#excel #vba #schedule

#excel #vba #Расписание

Вопрос:

Я надеюсь, что кто-нибудь может помочь мне в решении проблемы, которая у меня есть. Я создал рабочую книгу, чем при открытии запустил несколько макросов:

Refresh_time — выполняется каждую секунду для обновления счетчика времени

Save_it — сохраняет файл каждые 30 минут

Заказ — запускает marco Save_order в определенное время, 02, 10 и 18 часов

Также есть несколько маркосов, которые закроют файл, если в течение 10 минут не будет активности.

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

У кого-нибудь есть идеи, где я допустил ошибку?

В этой рабочей тетради

 Private Sub Workbook_Open()

    Refresh_time
    Save_it
    Order
    TimeSetting

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    
    Application.DisplayAlerts = False
    ActiveWorkbook.Save
    
    Stop_
    TimeStop
    
    On Error GoTo 0
    Application.DisplayAlerts = True

End Sub
 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

   TimeStop
   TimeSetting

End Sub

В модуле1

 Public dTimeB, dTimeS, dTimeT1, dTimeT2, dTimeT3, CloseTime As Date


Sub Stop_()


    Application.OnTime dTimeB, "Refresh_time", , False
    Application.OnTime dTimeS, "Save_it", , False
    Application.OnTime dTimeT1, "Save_order", , False
    Application.OnTime dTimeT2, "Save_order", , False
    Application.OnTime dTimeT3, "Save_order", , False
    
End Sub

Sub TimeSetting()


    On Error Resume Next
    Application.OnTime EarliestTime:=CloseTime, Procedure:="SavedAndClose", Schedule:=False
    On Error GoTo 0
    CloseTime = Now()   TimeValue("00:03:00")
    Application.OnTime EarliestTime:=CloseTime, Procedure:="SavedAndClose", Schedule:=True

End Sub
Sub TimeStop()

    On Error Resume Next

    Application.OnTime EarliestTime:=CloseTime, _
      Procedure:="SavedAndClose", Schedule:=False

 End Sub
Sub SavedAndClose()

    ActiveWorkbook.Close Savechanges:=True

End Sub

Sub Refresh_time()

    Dim Smena_1, Smena_2, Smena_3 As Date
    
    On Error Resume Next
    Application.OnTime EarliestTime:=dTimeB, Procedure:="Refresh_time", Schedule:=False
    On Error GoTo 0
    dTimeB = Now()   TimeValue("00:00:01")
    Application.OnTime EarliestTime:=dTimeB, Procedure:="Refresh_time", Schedule:=True
    
    Smena_1 = Date   TimeValue("10:00:00")
    Smena_2 = Date   TimeValue("18:00:00")
    Smena_3 = Date   1   TimeValue("02:00:00")
    vreme = Date   Time
    
    If vreme < Smena_1 Then
        Y = Smena_1 - vreme
        Else
        If vreme < Smena_2 Then
            Y = Smena_2 - vreme
            Else
                Y = Smena_3 - vreme
    
        End If
    End If
        Workbooks("Lager MES REO zica_MM.xlsm").Worksheets("Pocetna").Vreme_porucivanja.Value = Format(Y, "hh:mm:ss")
    
        Workbooks("Lager MES REO zica_MM.xlsm").Worksheets("Pocetna").Za_porucivanje.Value = Application.CountA(Workbooks("Lager MES REO zica_MM.xlsm").Worksheets("Za porucivanje").Range("A:A")) - 1

End Sub

Sub Save_it()

    Application.DisplayAlerts = False
    
    ThisWorkbook.Save
    
    Application.DisplayAlerts = True

    On Error Resume Next
    Application.OnTime EarliestTime:=dTimeS, Procedure:="Save_it", Schedule:=False
    On Error GoTo 0
    dTimeS = Now()   TimeValue("00:10:00")
    Application.OnTime EarliestTime:=dTimeS, Procedure:="Save_it", Schedule:=True

End Sub

Sub Order()

    On Error Resume Next
    Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=False
    On Error GoTo 0
    dTimeT1 = TimeValue("02:00:00")
    Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True

    On Error Resume Next
    Application.OnTime EarliestTime:=dTimeT2, Procedure:="Save_order", Schedule:=False
    On Error GoTo 0
    dTimeT2 = TimeValue("10:00:00")
    Application.OnTime EarliestTime:=dTimeT2, Procedure:="Save_order", Schedule:=True

    On Error Resume Next
    Application.OnTime EarliestTime:=dTimeT3, Procedure:="Save_order", Schedule:=False
    On Error GoTo 0
    dTimeT3 = TimeValue("18:00:00")
    Application.OnTime EarliestTime:=dTimeT3, Procedure:="Save_order", Schedule:=True

End Sub

Я сделал, как вы предложили, но все еще не в порядке (код обновляется). Кроме того, при запуске макроса заказа, скажем, в 10:00, он выполняется 3 раза. Можете ли вы помочь мне с этим немного больше?

Ответ №1:

Вы делаете большинство вещей правильно с помощью application.ontime. Но есть одна вещь, которую вы должны добавить. Перед установкой нового времени включения удалите предыдущее.
В качестве примера:

 dTimeT1 = now()   TimeValue("00:10:00")
Application.OnTime dTimeT1, "Save_order"

Я бы тоже изменил это:

 on error resume next ' in case dTimeT1 is not set
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=False
on error goto 0
dTimeT1 = now()   TimeValue("00:10:00")
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True

Потому что, если dTimeT1 — это время в будущем, вы можете получить два установленных application.ontimes, но вы не можете удалить предыдущее, потому что ваша переменная была изменена.
Поэтому всегда очищайте предыдущий, а затем устанавливайте новый. Эта проблема возникает при запуске макроса вручную.

Конкретно к вашему вопросу:
я не уверен в вашей функции остановки. Почему вы сначала устанавливаете расписание, а затем удаляете его?

Почему бы и нет?

 Sub Stop_()
    on error resume next
    Application.OnTime EarliestTime:=dTimeB, Procedure:="Refresh_time", Schedule:=False
    Application.OnTime EarliestTime:=dTimeS, Procedure:="Save_it", Schedule:=False
    Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=False
    Application.OnTime EarliestTime:=dTimeT2, Procedure:="Save_order", Schedule:=False
    Application.OnTime EarliestTime:=dTimeT3, Procedure:="Save_order", Schedule:=False
    on error goto 0 
End Sub

В качестве примера того, как это является проблемой:

 ' set this to some time in future
dTimeT1 = TimeValue("12:00:00") 
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True

' we now set a new time
dTimeT1 = TimeValue("12:05:00")
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=True

' we simulate a close of the workbook which should remove the schedule
Application.OnTime EarliestTime:=dTimeT1, Procedure:="Save_order", Schedule:=false

Но этот код все равно будет выполняться в 12:00, потому что вы установили два расписания, но удаляете только одно.

Метки: