Hallo,
dann so:
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)
For Each raZelle In raBereich
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 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
End If
Next raZelle
End With
Application.CutCopyMode = False
Set raBereich = Nothing
End Sub
Gruß Werner
|