Code anpassen

Hey all,
Ich habe separat einen Code für Geburtstage setzten und Feiertage setzen.
Feiertage sind variabel wegen Bundesländer. Das klappt soweit alles.
Jetzt würde ich gerne noch über einen Button die Geburtstage und Feiertage gleichzeitig anzeigen lassen.
Ferner sollte er mir auch gleichzeitig in der Tabelle Basisdaten in Spalte D Filtern für F = Feiertage, G = Geburtstage und leere
da zwischen den Feiertagen und Geburtstagen leere Zeilen liegen.

Sub Feier_Geburtstag_setzen()

Dim rng1 As Range, rng2 As Range

    Dim yn As Integer

    Application.EnableEvents = False

    Set shKal = Worksheets("Kalender")

    Set shBd = Worksheets("Basisdaten")

    shKal.Cells(1, 12).Value = "Kalender"  ' in L1

    shKal.Cells(35, 12).Value = "Kalender" ' in L35

    shKal.Range("A3:X67").Interior.Color = -4142   ' -4142 / xlColorIndexNone / xlNone keine Farbe

    shKal.Range("C3:C33,G3:G33,K3:K33,O3:O33," & _

        "S3:S33,W3:W33,C37:C67,G37:G67,K37:K67,O37:O67,S37:S67,W37:W67").ClearContents  ' Inhalte der Zellen löschen

    yn = MsgBox("Feier u. Gburtstage setzen ?", vbYesNo + vbQuestion, "Sicherheitsabfrage")   ' Abfrage ja nein

    Range("A1").Select

    If yn = 7 Then Exit Sub ' bei 7 nein Abbruch

    shKal.Cells(1, 12).Value = "Feier u. Geburtstags - Kalender"

    shKal.Cells(35, 12).Value = "Feier u. Geburtstags - Kalender"

    For Each rng1 In shBd.Range("B2:B20")   'Feiertage holen

      For Each rng2 In shKal.Range("A3:A33,E3:E33,I3:I33,M3:M33," & _

        "Q3:Q33,U3:U33,A37:A67,E37:E67,I37:I67,M37:M67,Q37:Q67,U37:U67")

        If rng2 = rng1 Then

          shKal.Range(rng2.Address & ":" & _

            rng2.Offset(0, 3).Address).Interior.ColorIndex = 34 ' Türkis

          shKal.Range(rng2.Offset(0, 2).Address) = shBd.Cells(rng1.Row, 1)

          shKal.Range(rng2.Offset(0, 2).Address).Font.Size = 10

        End If

      Next

    Next

    For Each rng1 In shBd.Range("C21:C" & shBd.Cells(Rows.Count, 3).End(xlUp).Row)  'Geburtstage holen

      For Each rng2 In shKal.Range("A3:A33,E3:E33,I3:I33,M3:M33," & _

        "Q3:Q33,U3:U33,A37:A67,E37:E67,I37:I67,M37:M67,Q37:Q67,U37:U67")

        If rng2 = rng1 Then

          shKal.Range(rng2.Address & ":" & _

            rng2.Offset(0, 3).Address).Interior.ColorIndex = 34 'Türkis

          shKal.Range(rng2.Offset(0, 2).Address) = shBd.Cells(rng1.Row, 1)

          shKal.Range(rng2.Offset(0, 2).Address).Font.Size = 10

        End If

      Next

    Next

    shKal.Range("A1").Select

    Application.EnableEvents = True

    

End Sub

Der Code klappt so halbwegs, ich habe das Problem wenn zb. der Feiertag und Geburtstag auf dem selben Datum fällt
zeigt er mir nur den Geburtstag an aber keinen Feiertag.
Wo ist mein Fehler ?
Das mit der Filterung bekomme ich auch leider nicht hin. Muss ich dafür neues Thema aufmachen ?
Vielen Dank im Voraus der Mühe.

MfG
Dieter

Hallo Dieter,

um die Handlung einfacher zu machen, habe ich die Schleifen getauscht: zuerst über alle Kalenderzellen, darin einmal über Feiertage, einmal über Geburtstage. Die Ergebnis werden zuerst in einer Variable abgelegt, dann in der Zelle.

rng1 und rng2 habe ich in zKal und zBas umbenannt.
Die Zellenliste (eigentlich nur einen Text) habe ich als Konstante abgelegt. Änderungen müssen dann nur an einer Stelle gemacht werden.

Du kannst eine Zelle rng1 direkt adressieren, es muss nicht daraus die Adresse gelesen und ein Range aufgebaut werden.

Sub Feier_Geburtstag_setzen()

Dim shKal As Worksheet

Dim shBas As Worksheet

Dim zBas As Range

Dim zKal As Range

Dim Msg As String



Const cZellen = "A3:A33,E3:E33,I3:I33,M3:M33,Q3:Q33,U3:U33,A37:A67,E37:E67,I37:I67,M37:M67,Q37:Q67,U37:U67"

Const cTrenner = ", "



    Application.EnableEvents = False

    

    Set shKal = Worksheets("Kalender")

    Set shBas = Worksheets("Basisdaten")

    shKal.Cells(1, 12).Value = "Kalender"  ' in L1

    shKal.Cells(35, 12).Value = "Kalender" ' in L35

    shKal.Range("A3:X67").Interior.Color = -4142   ' -4142 / xlColorIndexNone / xlNone keine Farbe

    shKal.Range(cZellen).Offset(0, 2).ClearContents ' Inhalte der Zellen löschen

    shKal.Range("A1").Select

    If MsgBox("Feier u. Geburtstage setzen ?", vbYesNo + vbQuestion, "Sicherheitsabfrage") > vbYes Then Exit Sub ' bei alles anderes als Ja Abbruch

    

    shKal.Cells(1, 12).Value = "Feier u. Geburtstags - Kalender"

    shKal.Cells(35, 12).Value = "Feier u. Geburtstags - Kalender"

    

    For Each zKal In shKal.Range(cZellen)

        Msg = ""

    'Feiertage holen

        For Each zBas In shBas.Range("B2:B20")

            If zKal.Value = zBas.Value Then Msg = cTrenner & shBas.Cells(zBas.Row, 1).Value

        Next

    'Geburtstage holen

        For Each zBas In Range(shBas.Range("C21"), shBas.Cells(Rows.Count, 3).End(xlUp))

            If zKal.Value = zBas.Value Then Msg = Msg & cTrenner & shBas.Cells(zBas.Row, 1).Value

        Next

    'Ergebnis setzen

        If Msg > "" Then

            zKal.Resize(1, 3).Interior.ColorIndex = 34 'Türkis

            zKal.Offset(0, 2).Value = Mid(Msg, Len(cTrenner) + 1) 'ohne vorangestellten Trenner

            zKal.Offset(0, 2).Font.Size = 10

        End If

    Next

    shKal.Range("A1").Select

    

    Application.EnableEvents = True

End Sub

Ich hoffe, Du erkennst deinen Code wieder :-)

VG
Yal

Forumthread: Code anpassen

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Code anpassen

Forumthread: Code anpassen

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread