sub test
Dim LetzteZeile As Integer
Dim BereichsAnfang As Integer
Dim BereichsEnde As Integer
Dim AktuelleZeile As Integer
Dim NurLeereZeile As Boolean
Dim i As Integer
Dim Dateiname As String
Dim wb As Workbook
Dim Standardbereich
Application.ScreenUpdating = False
Set wb = ActiveWorkbook
' Letzte Zeile in Spalte A ermitteln
LetzteZeile = Range("A65536").End(xlUp).Row
BereichsEnde = 1
AktuelleZeile = 1
' Außere Schleife
Do
BereichsAnfang = AktuelleZeile
Do
' Zähler erhöhen, bis Änderung auftritt
AktuelleZeile = AktuelleZeile + 1
Loop Until Cells(BereichsAnfang, 1) <> Cells(AktuelleZeile, 1)
' Bereichsende ist eine Zeile darüber
BereichsEnde = AktuelleZeile - 1
' Prüfen, ob evtl nur leere Zeile.
' Dann kann man sich das Kopieren und Speichern ersparen
NurLeereZeile = True
For i = BereichsAnfang To BereichsEnde
If Cells(i, 1) <> "" Then
NurLeereZeile = False
Exit For
End If
Next
' Wenn wenigstens eine Zelle im Bereich in Spalte A nicht leer ist,
' Bereich in neue Mappe kopieren und speichern
If NurLeereZeile = False Then
Dateiname = (Cells(BereichsAnfang, 1))
Range(Cells(BereichsAnfang, 1), Cells(BereichsEnde, 14)).Select
Selection.Copy
End If
Loop Until AktuelleZeile > LetzteZeile
Application.ScreenUpdating = True
End Sub
dieses makro kopiert den bereich mit gleichem datum in die zwischenablage und wurde erstellet mit der freundlcihen hilfe von johannes aus dem www.ms.office-forum.de