Hallo Werner,

Sorry mein fehler:)

Die Emails stehent in "Stammdaten" Spalte L ab Zeile 2 und sollen nach "Email" Spalte C entsprechend zu ihren besitzern. Soweit hab ich es.

Wenn nun keine Email vorhanden ist soll er den Eintrag nicht kopieren und mit dem nächsten Mitglieg weiter machen.

Ich habe es mit folgendem Code probiert, der will aber nicht wirklich tun....

Option Explicit
 
Public Sub Geburtstagsliste()
Dim raBereich As Range, raZelle As Range, i As Long
 
Application.ScreenUpdating = False
'<Clear Email Form >
Worksheets("Email").Range("B9:I27").ClearContents
With Worksheets("Stammdaten")
    Set raBereich = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    Set raMail = .Range("L2:L" & .Cells(.Rows.Count, "L").End(xlsUp).Row)
    For Each raZelle In raBereich
        If Month(raZelle) = Month(Date) Then
            If Day(raZelle) = Day(Date) Then
                
				With Worksheets("Stammdaten")
				if .Cells [2, "L"].value= "" Then i=i+1
				end with
				end if				

                With Worksheets("Email")
               '<Prüfe ob Form Leer ist>
                    If .Cells(9, "F") = "" Then i = 9
                    '<Copy Name to Form>
                    raZelle.Offset(, -3).Copy
                    .Cells(i, "E").PasteSpecial Paste:=xlPasteValues
                    '<Copy Firstname to Form>
                    raZelle.Offset(, -2).Copy
                    .Cells(i, "F").PasteSpecial Paste:=xlPasteValues
                    '<Copy Age to Form>
                    raZelle.Offset(, 1).Copy
                    .Cells(i, "G").PasteSpecial Paste:=xlPasteValues
                    '<Copy Gender to Form>
                    raZelle.Offset(, 9).Copy
                    .Cells(i, "H").PasteSpecial Paste:=xlPasteValues
                    '<Copy Email Adress to Form>
                    raZelle.Offset(, 8).Copy
                    .Cells(i, "C").PasteSpecial Paste:=xlPasteValues
                    '<Copy Bday to Form>
                    raZelle.Copy
                    .Cells(i, "I").PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                    i = i + 1
                End With
            End If
        End If
    Next raZelle
End With
Application.CutCopyMode = False
 
Set raBereich = Nothing
End Sub