Geburtstage der nächsten 7 Tage aus mitarbeiterliste per MsgBox anzeigen

  • Excel

Es gibt 3 Antworten in diesem Thema. Der letzte Beitrag () ist von petaod.

    Geburtstage der nächsten 7 Tage aus mitarbeiterliste per MsgBox anzeigen

    Guten tag, ich bin ein Anfänger mit VBA Programierung.
    Zu meinem Problem, ich habe eine Personalliste in Excel, welche dem Nutzer beim Start die Geburtstage der nächsten 7 Tage anzeigt.
    Das funktioniert auch, aber dauert recht lange 45-60 sec und manchmal schmiert Excel mir ab.
    Vielleicht helft ihr mir auf die Sprünge wie ich dieses Problem anders lösen kann.
    Da es solange dauert habe ich es derzeit über einen Command Button laufen, soll aber falls sich die abfrage beschleunigen lässt als Workbook_open laufen.

    Geburtstage der Mitarbeiter stehen im Bereich H3:H403 in dem Format "TT.MM.JJJ" bsp "12.06.1961"
    in Spalte J steht das Geburtstag in diesem Jahr bsp. "12.06.2018"
    Spalte E = Nachname
    Spalte F= Vorname
    Zeile 2 sind die Überschriften meiner Tabelle und Zeile 1 ist als Platzhalter für die Commandbuttons

    Am liebsten wäre es mir wenn er in Der MsgBox einzeln auflistet Tageweise wer da Geburtstag hat, dann brauche ich das nicht in der Ausgabezeile wie es bisher in meinem Code ist

    Hier der Code:



    Sub Birthday()
    Dim rng As Range
    Dim cel As Range
    Dim strMsg As String
    On Error Resume Next
    If MsgBox("Wollen Sie alle Geburtstage der nächsten 7 Tage angezeigt bekommen? (Dauer ca 45 Sekunden)", vbYesNo) = vbNo Then Exit Sub
    With Sheets("Speicherort")


    For Each rng In .Range("Speicherort!H3:H403" & Application.max(2, .Cells(.Rows.Count, 10).End(xlUp).Row))
    If DateSerial(Year(Date), Month(rng), Day(rng)) = Date Or _
    DateSerial(Year(Date), Month(rng), Day(DateAdd("d", -1, rng))) = Date Or _
    DateSerial(Year(Date), Month(rng), Day(DateAdd("d", -2, rng))) = Date Or _
    DateSerial(Year(Date), Month(rng), Day(DateAdd("d", -3, rng))) = Date Or _
    DateSerial(Year(Date), Month(rng), Day(DateAdd("d", -4, rng))) = Date Or _
    DateSerial(Year(Date), Month(rng), Day(DateAdd("d", -5, rng))) = Date Or _
    DateSerial(Year(Date), Month(rng), Day(DateAdd("d", -6, rng))) = Date Or _
    DateSerial(Year(Date), Month(rng), Day(DateAdd("d", -7, rng))) = Date Then
    strMsg = strMsg & Left(.Cells(rng.Row, 5).Text & " " & .Cells(rng.Row, 6).Text, 35) & " wird " & Year(Date) - Year(rng) & " Jahre alt am " & Left(.Cells(rng.Row, 10).Text, 35) & vbLf
    End If
    Next

    End With

    If Len(strMsg) Then
    strMsg = "Heute ist der " & Format(Date, "dddd, dd.MM.yyyy") & vbLf & vbLf & strMsg
    MsgBox strMsg
    End If

    On Error GoTo 0

    End Sub



    PS: Hoffe das ist nachvollziehbar :) danke schonmal

    Newbeevba schrieb:

    For Each rng In .Range("Speicherort!H3:H403" & Application.max(2, .Cells(.Rows.Count, 10).End(xlUp).Row))

    Lass mal die 403 weg, sonst zählt der bei 20 gefüllten Zellen bis Zeile 40320

    Noch ein Tipp:
    Schau dir die DateDiff-Funktion an, dann kannst du aus deiner If...Or..Or.....ThenKonstruktion einen Einzeiler machen.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    AndPod schrieb:

    Aber selbst bei >40000 Zeilen dürfte das keine 45 Sekunden dauert.
    Dann lass es 100 relevante Zeilen sein, dann sind es schon 403100 Durchläufe.
    Da kommst du schon irgendwann in den kritischen Bereich.
    Jedenfalls muss dieser Blödsinn erst mal weg, bevor weitere Tests Sinn machen.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --