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
|