Supportnet Computer
Planet of Tech

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:

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

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: