Bestimmte Zeilen aus mehreren Datensätzen auslesen und in neues Excel File schreiben

Sub ZeilenFiltern()
Set Quelle = ThisWorkbook
Set Ziel = Workbooks.Add

Zieldatei = "D:\Auszug.xlsx" 'Pfad der Zieldatei  
ZZeile = 1 'erste Zeile der Zieltabelle  
QZeile = 1 'erste zu verarbeitende Zeile der Quelltabelle  
QSpalten = 5 'erste 5 Spalten der Quelltabelle übertragen  
QKritSpalte = "B" 'Spalte mit dem Kriterium (Timestamp)  

Zuletzt = 0 ' Startwert für Datum setzen  
Termin1 = True 'Kennzeichen für "Wert für Termin1 übertragen"  
Termin2 = True 'Kennzeichen für "Wert für Termin2 übertragen"  
With Quelle.Worksheets(1)
    'Überschriftenzeile übertragen  
    Ziel.Worksheets(1).Cells(ZZeile, "A").Resize(1, QSpalten) = .Cells(QZeile, "A").Resize(1, QSpalten).Value 'Zellen ab Spalte A übertragen  
    QZeile = QZeile + 1 'nächste Zeile der Quelldatei  
    ZZeile = ZZeile + 1 'nächste Zeile der Zieldatei  
    
    Datum = Int(.Cells(QZeile, QKritSpalte).Value) 'Datum aus aktueller Zeile der Quelldatei auslesen  
    Zeit = .Cells(QZeile, QKritSpalte).Value - Datum 'Uhrzeit aus aktueller Zeile der Quelldatei ermitteln  
    Do Until Datum = 0 'alle Datenzeilen der Quelldatei durchgehen  
        If Datum <> Zuletzt Then
            If Termin1 Then 'nur einmal am Tag den Datensatz für Termin1 übertragen  
                If Zeit >= 0 Then ' 0 = 00:00:00; Abfrage eigentlich nicht nötig (nur, falls ein anderer Zeitpunkt vewendet werden sollte)  
                    Ziel.Worksheets(1).Cells(ZZeile, "A").Resize(1, QSpalten) = .Cells(QZeile, "A").Resize(1, QSpalten).Value 'Zellen ab Spalte A übertragen  
                    ZZeile = ZZeile + 1 'nächste Zeile der Zieldatei  
                    Termin1 = False 'Termin1 an diesem Tag nicht nochmals übertragen  
                    Termin2 = True 'Termin2 kann übertragen werden  
                End If
            End If
            If Termin2 Then 'nur einmal am Tag den Datensatz für Termin2 übertragen  
                If Zeit >= 0.5 Then ' 0.5 = 12:00:00  
                    Ziel.Worksheets(1).Cells(ZZeile, "A").Resize(1, QSpalten) = .Cells(QZeile, "A").Resize(1, QSpalten).Value 'Zellen ab Spalte A übertragen  
                    ZZeile = ZZeile + 1 'nächste Zeile der Zieldatei  
                    Zuletzt = Datum 'verarbeitetes Datum zwischenspeichern  
                    Termin2 = False 'Termin2 an diesem Tag nicht nochmals übertragen  
                    Termin1 = True 'Termin1 kann übertragen werden (ist aber erst wieder am nächsten Tag möglich - siehe "Zuletzt")  
                End If
            End If
        End If
        QZeile = QZeile + 1 'nächste Zeile der Quelldatei  
        Datum = Int(.Cells(QZeile, QKritSpalte).Value) 'Datum aus aktueller Zeile der Quelldatei auslesen  
        Zeit = .Cells(QZeile, QKritSpalte).Value - Datum 'Uhrzeit aus aktueller Zeile der Quelldatei ermitteln  
    Loop
End With
Ziel.Worksheets(1).Columns.AutoFit 'alle Spalten der Zieldatei auf optimale Breite setzen  
Ziel.SaveAs Zieldatei 'Zieldatei speichern  
End Sub