Supportnet / Forum / Tabellenkalkulation
VBA Geburtstagsliste
Frage
Hallo Excelexperten,
ich habe einen Code für eine Geburtstagsliste gefunden,
wie muss der Code verändert werden, damit er auch einen Tag nach dem Geburtstag noch mit angezeigt wird.
Ich hoffe ihr könnt mir weiterhelfen.
Gruß
fedjo
Option Explicit
Sub Geburtstag()
Dim intgeb As Integer
Dim Loletzte As Long
Dim MsgText As String
Dim intalter As Integer
Loletzte = IIf(IsEmpty(Range("A65536")), Range("A65536").End(xlUp).Row, 65536)
For intgeb = 2 To Loletzte
intalter = (DateSerial(Year(Date), Month(Date), Day(Date)) - DateSerial(Year(Cells(intgeb, 1)), Month(Cells(intgeb, 1)), _
Day(Cells(intgeb, 1)))) / 365.25
If DateSerial(Year(Date), Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) >= DateSerial(Year(Date), Month(Date), _
Day(Date)) And DateSerial(Year(Date), Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) <= DateSerial(Year(Date), _
Month(Date), Day(Date) + 0) Or DateSerial(Year(Date) + 1, Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) _
<= DateSerial(Year(Date), Month(Date), Day(Date) + 0) Then
MsgText = MsgText & vbLf & vbLf & Cells(intgeb, 1 + 2) & " " & Cells(intgeb, 1 + 1) _
& " " & "wird " & intalter & " Jahre alt"
End If
Next intgeb
If Len(MsgText) > 0 Then
MsgBox Right(MsgText, Len(MsgText) - 2), , "Geburtstag haben heute"
Else
MsgBox "heute hat keiner Geburtstag", , "Geburtstag"
End If
End Sub
Antwort 1 von Kauz
Hallo Fedjo...
bin mir nicht ganz sicher, ob es tadellos funzt...
trotzdem hier ein geänderter code:
Probier's aus...
Gruß
Andreas
bin mir nicht ganz sicher, ob es tadellos funzt...
trotzdem hier ein geänderter code:
Option Explicit
Dim intgeb As Integer
Dim Loletzte As Long
Dim MsgText As String
Dim intalter As Integer
Sub Geburtstag()
Loletzte = IIf(IsEmpty(Range("A65536")), Range("A65536").End(xlUp).Row, 65536)
For intgeb = 2 To Loletzte
intalter = (DateSerial(Year(Date), Month(Date), Day(Date)) - DateSerial(Year(Cells(intgeb, 1)), Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1)))) / 365.25
If DateSerial(Year(Date), Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) >= DateSerial(Year(Date), Month(Date), Day(Date)) _
And DateSerial(Year(Date), Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) <= DateSerial(Year(Date), Month(Date), Day(Date) + 0) _
Or DateSerial(Year(Date) + 1, Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) <= DateSerial(Year(Date), Month(Date), Day(Date) + 0) Then
MsgText = MsgText & vbLf & vbLf & Cells(intgeb, 1 + 2) & " " & Cells(intgeb, 1 + 1) & " " & "wird " & intalter & " Jahre alt"
ElseIf DateSerial(Year(Date), Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) + 1 >= DateSerial(Year(Date), Month(Date), Day(Date)) _
And DateSerial(Year(Date), Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) <= DateSerial(Year(Date), Month(Date), Day(Date) + 0) _
Or DateSerial(Year(Date) + 1, Month(Cells(intgeb, 1)), Day(Cells(intgeb, 1))) <= DateSerial(Year(Date), Month(Date), Day(Date) + 0) Then
MsgText = MsgText & vbLf & vbLf & Cells(intgeb, 1 + 2) & " " & Cells(intgeb, 1 + 1) & " " & "ist gestern " & intalter & " Jahre alt geworden"
End If
Next intgeb
If Len(MsgText) > 0 Then
MsgBox Right(MsgText, Len(MsgText) - 2), , "Geburtstag haben heute"
Else
MsgBox "heute hat keiner Geburtstag", , "Geburtstag"
End If
End Sub
Probier's aus...
Gruß
Andreas
Antwort 2 von fedjo
Hallo Andreas,
der Code funktioniert einfach perfekt.
Danke für deine Hilfe.
Gruß
fedjo
der Code funktioniert einfach perfekt.
Danke für deine Hilfe.
Gruß
fedjo