2 Subs mit dem selben Namen
30.06.2017 09:40:47
Robert
Ich habe eine große Tabelle und will Änderungen auf bestimmten Blättern protokollieren. Da diese Liste aber auch von sehr vielen Mitarbeitern genutzt wird, soll sie sich aber auch selbstständig speichern und schließen.
es geht um den Vorgang "_P_rivate Sub Workbook_SheetChange" vor dem Code mit dem Protokoll ging es super mit der Änderung der Blätter das der Timer neu startet. jetzt wird bei jeder Änderung Das Infofenster angezeigt das sich die Tabelle in einer Minute schließt. wie bekomme ich den code wieder getrennt aber kann beide behalten, bzw wie pusht sich der Code nicht neu hoch?
Folgender Code ist in meiner Arbeitsmappe vorhanden:
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
End Sub
Private Sub Workbook_Open()
dteCloseTime = Now + TimeSerial(0, 9, 0)
Application.OnTime dteCloseTime, "DoClose"
Sheets(1).Select
Call Tabelle8.Verbergengruen
Call AutorundDatumReload
Call starthinweis
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, 9, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
If Sh.CodeName "Tabelle16" Then
'damit DIESE Prozedur durch Eingaben in Tabelle 16
'NICHT gestartet wird
Application.EnableEvents = False
With Tabelle16
lngLZ = .Cells(1, 1).End(xlDown).Row + 1
If lngLZ > Rows.Count Then
Call NeuesProtokoll
'erste freie Zeile in wksDoku ermitteln
lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
.Cells(lngLZ, 2) = ActiveSheet.Name
.Cells(lngLZ, 3) = ActiveSheet.CodeName
.Cells(lngLZ, 6) = Environ("Username")
.Cells(lngLZ, 7) = Environ("Computername")
.Cells(lngLZ, 8) = ThisWorkbook.FullName
For Each rngZelle In Target
.Cells(lngLZ, 1) = Now
.Cells(lngLZ, 4) = rngZelle.Address(False, False)
If rngZelle.Value = "" Then
.Cells(lngLZ, 5) = ""
Else
.Cells(lngLZ, 5) = rngZelle.Value
End If
lngLZ = lngLZ + 1
If lngLZ > Rows.Count Then
Call NeuesProtokoll
lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
Next
End With
Application.EnableEvents = True
End If
Exit Sub
Fehler:
lngLZ = Tabelle16.Cells(1, 1).End(xlDown).Row + 1
If lngLZ > Rows.Count Then
Call NeuesProtokoll
lngLZ = Tabelle16.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
With Tabelle16
.Cells(lngLZ, 1) = Now
.Cells(lngLZ, 2) = "Err.Number: " & Err.Number
.Cells(lngLZ, 3) = "Err.Description: " & Err.Description
End With
lngLZ = Tabelle16.Cells(1, 1).End(xlDown).Row + 1
If lngLZ > Rows.Count Then
Call NeuesProtokoll
lngLZ = Tabelle16.Cells(Rows.Count, 1).End(xlUp).Row + 1
End If
Resume Next
End Sub
Private Sub NeuesProtokoll()
'entfernt alle Protololleinträge in wksDoku
'und schafft damit Platz für neue
With Tabelle16
.Range(.Cells(3, 1), .Cells(Rows.Count, Columns.Count)).Clear
.Cells(3, 1) = Now
.Cells(3, 2) = "ALTES PROTOKOLL GELÖSCHT!!!"
'erste freie Zeile in wksDoku ermitteln
'lngLZ = .Cells(Rows.Count, 1).End(xlUp).Row + 1
End With
End Sub
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
On Error Resume Next
Application.OnTime dteCloseTime, "DoClose", , False
dteCloseTime = Now + TimeSerial(0, 9, 0)
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, 9, 0)
blnCloseNow = False
Application.OnTime dteCloseTime, "DoClose"
End Sub