Zeitstempel zu Transfer

Sub Daten_nach_Transfer()
Call aaa
Dim wksPlan As Worksheet, wksTransfer As Worksheet
Dim zeiP As Long, spaP As Long
Dim zeiPL As Long, spaPL As Long
Dim zeiT As Long
Dim sSchicht As String, datDatum As Date
Dim StatusCalc As Long
Const zeiStart = 3 '1. Zeile in die Transferdaten eingetragenn werden sollen
Set wksPlan = ActiveWorkbook.Worksheets("Personalplanung")
Set wksTransfer = ActiveWorkbook.Worksheets("DB_Transfer")
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
With wksTransfer
'Alte daten im Blatt Transfer löschen
zeiT = .Cells(.Rows.Count, 1).End(xlUp).Row
If zeiT >= zeiStart Then
.Range(.Cells(zeiStart, 1), .Cells(zeiT, 6)).ClearContents
End If
zeiT = zeiStart - 1
End With
With wksPlan
'letzte Zeile mit Daten in Spalte H
zeiPL = .Cells(.Rows.Count, 8).End(xlUp).Row
'letzte Spalte mit Mitarbiter-Zuordnung zu Anlage
spaPL = .Range("BE11").Column
sSchicht = .Range("AJ8").Value
datDatum = .Range("AJ6").Value
For spaP = 8 To spaPL Step 7
For zeiP = 11 To zeiPL Step 4
If .Cells(zeiP, spaP).Offset(1, 0).Value  "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(1, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(1, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(1, 1).Value 'Zeit
End If
If .Cells(zeiP, spaP).Offset(2, 0).Value  "" Then
zeiT = zeiT + 1
wksTransfer.Cells(zeiT, 1) = sSchicht
wksTransfer.Cells(zeiT, 2) = datDatum
wksTransfer.Cells(zeiT, 3) = .Cells(zeiP, spaP).Offset(2, 3).Value 'Anlage
wksTransfer.Cells(zeiT, 5) = .Cells(zeiP, spaP).Offset(2, 0).Value 'MA
wksTransfer.Cells(zeiT, 6) = .Cells(zeiP, spaP).Offset(2, 1).Value 'Zeit
End If
Next
Next
End With
Call DatenInAccessDB
Call Makro7
Call save
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
End With
End Sub