Sub KopiereHeute()
Const ez = 2 'bei einer Kopfzeile
Const Blattname_Heute = "Heute"
Dim lz As Long, i As Long
'evtl altes Blatt löschen
Application.DisplayAlerts = False
On Error Resume Next
Sheets(Blattname_Heute).Delete
On Error GoTo 0
Application.DisplayAlerts = True
'Aktives Blatt kopieren
Sheets("Tabelle1").Copy Before:=ActiveSheet.Next
ActiveSheet.Name = Blattname_Heute
lz = Range("A65536").End(xlUp).Row
Application.ScreenUpdating = False
'Spalte A in Werte
Columns("A:A").Copy
Columns("A:A").PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
'[A1].Select
Application.CutCopyMode = False
'Spalte H-(letzte) löschen
Columns("H:IV").Delete
'alles was nicht heute ist löschen
For i = lz To ez Step -1 '
If Cells(i, 1).Value <> Date Then
Rows(i & ":" & i).Delete Shift:=xlUp
End If
Next i
Cells(1, 1).Select
Application.ScreenUpdating = True
End Sub
Const ez = 1 'bei keiner Kopfzeile
^