Hallo Matthias,

Public Sub Geburtstagsliste()
Dim raBereich As Range, raZelle As Range, i As Long
   
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

'<Clear Email Form >
Worksheets("Email").Range("B9:I27").ClearContents
With Worksheets("Stammdaten")
    Set raBereich = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    For Each raZelle In raBereich
        Select Case Year(Date) - Year(raZelle)
            Case 50, 55, 60, 65, 70, 75, 80, 85, 90, 95, 100
                If Month(raZelle) = Month(Date) Then
                    If Day(raZelle) = Day(Date) Then
                        If raZelle.Offset(, 8) <> "" Then
                             With Worksheets("Email")
                            '<Prüfe ob Form Leer ist>
                                 If .Cells(9, "F") = "" Then i = 9
                                 '<Copy Name and Firstname to Form>
                                 raZelle.Offset(, -3).Resize(, 2).Copy
                                 .Cells(i, "E").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
                End If
            Case Else
        End Select
    Next raZelle
End With
Application.CutCopyMode = False
   
Set raBereich = Nothing
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub

Gruß Werner