Verschiedene Jubiläen in einer MsgBox anzeigen
25.09.2008 22:41:00
Steffan
ich habe eine Mitgliederliste, in der ich eine Geburtstagsabfrage habe. Das funzt prima. Nun wollte ich diese Abfrage um die Jubiläen der Vereinszugehörigkeit ergänzen. Das hat für ein Jubiläum (10 Jahre) auch geklappt, da ich nur die Formeln der Geburtstagsabfrage angepasst habe. Wenn ich aber nun die anderen Jubiläen (20,25,30,40 und 50 Jahre) ebenfalls hinten dran hänge, muss ich mich bei dem Makro durch eine Unzahl von MsgBoxen klicken. Wie kriege ich die anstehenden Jubiläen (also alle 6 möglichen) der jeweils nächsten 31 Tage in einer einzigen Box angezeigt? Klappt doch bei den Geburtstagen auch?
Hier hab ich noch den Code, den ich bisher geschrieben habe (ich hab bei 20 Jahre aufgehört, weil ich den Fehler bemerkt hab):
Private Sub Workbook_Open()
Dim sMldg1 As String, sMldg2 As String, lR As Long, iDiff As Integer
Dim sMldg3 As String, sMldg4 As String, iDiff1 As Integer
Const iVn As Integer = 3 ' Spalte C - Vornamen
Const iNn As Integer = 2 ' Spalte D - Nachnamen
Const iG As Integer = 7 ' Spalte H - Geburtstage
Const iEin As Integer = 8 ' Spalte I - Eintrittsdatum
Jub1 = 10 ' 10-jähriges Jubiläum
Jub2 = 20 ' 20-jähriges Jubiläum
Jub3 = 25 ' 25-jähriges Jubiläum
Jub4 = 30 ' 30-jähriges Jubiläum
Jub5 = 40 ' 40-jähriges Jubiläum
Jub6 = 50 ' 50-jähriges Jubiläum
ActiveSheet.Protect Password:=""
Beep
' Überprüfung auf Geburtstage (dieses Makro hab ich hier im Forum gefunden)
sMldg1 = "Geburtstage:" & vbLf
lR = 2
Do Until IsEmpty(Cells(lR, iVn))
iDiff = DateSerial(Year(Date), Month(Cells(lR, iG)), Day(Cells(lR, iG))) - Date
If iDiff "" Then
MsgBox "Geburtstage in den nächsten 31 Tagen:" & vbLf & sMldg2, , "Vorschau"
Else
MsgBox "Keine Geburtstage in den nächsten 31 Tagen!", , "Info"
End If
End If
' Überprüfung auf 10-jähriges Jubiläum
sMldg3 = "Jubiläum:" & vbLf
lR = 2
Do Until IsEmpty(Cells(lR, iVn))
iDiff1 = DateSerial(Year(Cells(lR, iEin)) + Jub1, Month(Cells(lR, iEin)), Day(Cells(lR, _
_
iEin))) - Date
If iDiff1 "" Then
MsgBox "Jubiläen in den nächsten 31 Tagen:" & vbLf & sMldg4, , "Vorschau"
Else
MsgBox "Keine Jubiläen in den nächsten 31 Tagen!", , "Info"
End If
End If
' Überprüfung auf 20-jähriges Jubiläum
sMldg5 = "Jubiläum:" & vbLf
lR = 2
Do Until IsEmpty(Cells(lR, iVn))
iDiff2 = DateSerial(Year(Cells(lR, iEin)) + Jub2, Month(Cells(lR, iEin)), Day(Cells(lR, _
_
iEin))) - Date
If iDiff2 "" Then
MsgBox "Jubiläen in den nächsten 31 Tagen:" & vbLf & sMldg6, , "Vorschau"
Else
MsgBox "Keine Jubiläen in den nächsten 31 Tagen!", , "Info"
End If
End If
End Sub