Hallo Zusammen,

Ich habe ein Problem mit dem automatischen Schließen einer Excel Liste.
Bis jetzt hat alles ganz gut geklappt, wir hatten nur das Problem, dass sich die Liste nach dem Schließen jeweils zum beenden des Makros wieder geöffnet hat. Ließ sich ganz einfach beheben. Ich habe jetzt einen Code, der in einem ansonsten leeren Excel Sheet einwandfrei funktioniert, wenn ich ihn in mein gewünschtes Dokument integriere erhalte ich aber an einer anderen Stelle (die eigentlich seit Monaten einwandfrei funktioniert) den Laufzeitfehler 1004. Ich habe mich auch schon in das Thema OnTime eingelesen, leider aber ohne Erfolg.

Hat jemand eine Idee, woran das liegen könnte oder wie man das Problem anders lösen kann?

Mein Code:

In diese Arbeitsmappe:

Private Sub Workbook_Open()
    
    
    Sheets("Projektliste").Activate
    ActiveSheet.Range("A1").Activate
    
    dteCloseTime = Now + TimeSerial(0, 0, 30)
    Application.OnTime dteCloseTime, "DoClose"
    
    Dim freiezeile As Long
    freiezeile = Cells(Rows.Count, 1).End(xlUp).Row + 1

Set Rng = ActiveSheet.Range(Cells(freiezeile, 1), Cells(10000, 4))
Set rng1 = ActiveSheet.Range(Cells(1, 1), Cells(6, 42))
ActiveSheet.Unprotect Password:="schutzprojektliste123"
ActiveSheet.Cells.Locked = False
Rng.Locked = True
rng1.Locked = True
ActiveSheet.Protect Password:="schutzprojektliste123", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, AllowInsertingRows:=True

ActiveSheet.Range("A1").Activate
    



End Sub


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Sheets("Projektliste").Activate
ActiveSheet.Unprotect Password:="schutzprojektliste123"
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
ActiveWindow.Zoom = 85
ActiveSheet.Range("B4") = Now() 'DIESE ZEILE VERURSACHT DEN LAUFZEITFEHLER
ActiveSheet.Protect Password:="schutzprojektliste123", DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, AllowInsertingRows:=True


    
End Sub


Private Sub Workbook_BeforeClose(Cancel As Boolean)

ThisWorkbook.SaveCopyAs "U:\1055_RT_Montage_MMZ\120_MTA\035_Projektliste_Projekte\Neue Projektliste\Backup Projektliste\" & "Backup Projektliste" & "_" & Format(Date, "dd_mm_yyyy") & ".xlsm"

On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
End Sub


End Sub


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, 0, 30)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub

Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, 0, 30)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, 0, 30)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub

'Und im Modul:

Option Explicit
Option Private Module
Public dteCloseTime As Date, blnCloseNow As Boolean

Public Sub DoClose()
If ThisWorkbook.ReadOnly = False Then
Dim strMsg As String
If blnCloseNow = False Then
  strMsg = "Diese Datei wurde seit 9 Minuten nicht bearbeitet und" & vbCrLf & _
    "wird bei weiterer Inaktivität in 1 Minute geschlossen."
  CreateObject("WScript.Shell").PopUp strMsg, 10, ThisWorkbook.Name, _
    vbOKOnly + vbInformation + vbSystemModal
  blnCloseNow = True
  dteCloseTime = Now + TimeSerial(0, 0, 30)
  Application.OnTime dteCloseTime, "DoClose"
Else
  If Workbooks.Count = 1 Then
    If ThisWorkbook.Saved = False Then
      ThisWorkbook.Save
    End If
    Application.Quit
  Else
    ThisWorkbook.Close True
  End If
End If
Else
End If
End Sub

Vielen Dank im Voraus!

Grüße Bettina