Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1968to1972
1968to1972
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt

Forumthread: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt

neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 08:30:15
Unwissender
Guten Morgen, vieleicht kann mir hier jemand weiterhelfen. Und zwar habe ich ein Makro welches ein neues Blatt erstellt per Button. Es gibt eine Abfrage, wie das neue Blatt heißen soll, dabei wird immer nach dem Schema mm_jj gearbeitet.
Jetzt gibt es aber noch ein festes Blatt was "Feiertage" heißt worin für 3 Jahre die Feiertage stehen (Zellen A2-A34).

Wie bekomme ich es jetzt hin, dass wenn man in der "Neues Blatt Abfrage" eine Prüfung einbaut, ob das eingegebene Datum was man ja nur zweistellig eingibt, geprüft wird, ob es für das Jahr noch Einträge in der Feiertagsliste/Blatt gibt, und wenn nicht soll es eine Meldung geben, dass man bitte erstmal die Feiertagsliste aktualisieren soll mit neuen Feiertagseinträge.

So Schaut der Code aus um das neue Blatt zu erstellen. Innerhalb des Blattes lasse ich Feiertage markieren, was natürlich nicht mehr geht wenn es gar keine aktuellen Einträge mehr in dem Feiertags-Blatt gibt... 


Private Sub CommandButton1_Click()



' Abfrage Monat und Jahr

Monat_1 = Format(DateSerial(Year(Now()), Month(Now()) + 1, 1), "MM")

Jahr_1 = Format(DateSerial(Year(Now()), Month(Now()) + 1, 1), "YY")

wbname = InputBox("Name des neuen Blatts: mm_jj", "Blatt benennen", Monat_1 & "_" & Jahr_1)

'Falls auf Abbrechen gedrückt wird -> nix machen

    If wbname = "" Then

        Exit Sub

    End If

    

    

ActiveSheet.Copy After:=Sheets(ActiveSheet.Index) 'Erstelle neues Blatt nach dem aktuell aktiven Blatt

ActiveSheet.Name = wbname 'Benenne das neue Blatt wie in der Abfrage angegeben

End Sub
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 09:42:18
hary
Moin 
Dim Monat_1 As Long, Jahr_1 As Long

Dim wbname As String

' Abfrage Monat und Jahr

  Monat_1 = Format(DateSerial(Year(Now()), Month(Now()) + 1, 1), "MM")

  Jahr_1 = Format(DateSerial(Year(Now()), Month(Now()) + 1, 1), "YY")

If Jahr_1 = Format(Application.Max(Worksheets("Feiertage").Range("A2:A34")), "YY") Then '--pruefen auf Jahr

  wbname = InputBox("Name des neuen Blatts: mm_jj", "Blatt benennen", Monat_1 & "_" & Jahr_1)

    'Falls auf Abbrechen gedrückt wird -> nix machen

    If wbname = "" Then

        Exit Sub

    End If

  ActiveSheet.Copy After:=Sheets(ActiveSheet.Index) 'Erstelle neues Blatt nach dem aktuell aktiven Blatt

  ActiveSheet.Name = wbname 'Benenne das neue Blatt wie in der Abfrage angegeben

Else

 MsgBox "Feiertage aktuellisieren"

End If

gruss hary
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 10:40:33
UweD
Hallo

So? 




Private Sub CommandButton1_Click()

    Dim Datum1 As Date, Datum2 As Date, wbname As String

    Dim WF, RNG As Range

    

    Set WF = WorksheetFunction

    Set RNG = Sheets("Feiertage").Columns("A") ' Spalte mit den Feiertagen

    

    ' Abfrage Monat und Jahr

    Datum1 = DateSerial(Year(Date), Month(Date) + 1, 1)

    

    wbname = InputBox("Name des neuen Blatts: mm_jj", "Blatt benennen", Format(Datum1, "MM_YY"))

    

    'Abbrechen gedrückt

    If wbname = "" Then

        Exit Sub

    End If

    

    'Datum aus Eingabe erzeugen

    Datum1 = DateSerial(Right(wbname, 2) + 2000, Left(wbname, 2), 1)

    

    

    'Blatt schon vorhanden

    If Not IsError(Evaluate("'" & wbname & "'!A1")) Then ' Hochkomma wegen möglicher Leerzeichen

        MsgBox wbname & ": ist schon vorhanden"

        Exit Sub

    End If

    

    'Feiertage in dem Monat?

    Datum2 = WF.EoMonth(Datum1, 0)

    If WF.CountIfs(RNG, ">=" & CLng(Datum1), RNG, "=" & CLng(Datum2)) > 0 Then

        MsgBox "Bitte erstmal die Feiertagsliste aktualisieren"

        Exit Sub

    End If

      

        

    ActiveSheet.Copy After:=Sheets(ActiveSheet.Index) 'Erstelle neues Blatt nach dem aktuell aktiven Blatt

    ActiveSheet.Name = wbname 'Benenne das neue Blatt wie in der Abfrage angegeben

End Sub

LG UweD
Anzeige
Feiertagsblatt automatisch updaten
06.03.2024 15:31:09
Peter Trawinski
Hallo Uwe,

ohne mich in deine Diskussion mit den anderen Helfern hier einmischen zu wollen.

Wenn du in Deutschland lebst, kannst du deine Feiertage für jedes Jahr mit dieser Mappe automatisch berechnen:
https://www.herber.de/bbs/user/167831.xlsx
Habe sie heute nochmal erweitert um regionale Feiertage.

Vielleicht kannst du das ja brauchen.
Keine Notwenigkeit mehr, sie für neue Kalenderjahre einzutippen...
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 11:05:09
UweD
Ich nochmal

Wenn du prüfen möchtest, ob noch Feiertage bis zum Jahresende vorhanden sind, dann ändere die eine Zeile ab 

aus

Datum2 = WF.EoMonth(Datum1, 0)

wird

Datum2 = DateSerial(Right(wbname, 2) + 2000, 12, 31)



LG UweD
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 11:27:24
Unwissender
Wow, erstmal vielen lieben dank für eure Unterstützung und den Codes :)
@Hary, bei deinem Code bekomme ich sofort beim ausführen des Makros die Meldung "Feiertage aktualisieren"
@UweD, bei deinem Code geht es schon weiter, da kommt noch die Abfrage wie das neue Blatt heißen soll, danach kommt aber die Meldung mit den Feiertagsliste aktualisieren. Ich hab hier mal eine Dummy Datei angefügt, wie die Eigentliche Excel ausschaut

https://www.herber.de/bbs/user/167811.xlsm
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 11:45:54
hary
Moin
Mein Fehler. Fuer meinen Code.
Es muss natuerlich geprueft werden auf kleiner/gleich. 
If Jahr_1 = Format(Application.Max(Worksheets("Feiertage").Range("A2:A34")), "YY") Then

gruss hary
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 11:46:19
UweD
Hallo nochmal

Was genau soll den geschehen?

- 04_24 existiert ja
- aktuell würde aber genau der nächste Monat vorgeschlagen 04_24
- änderst du nun auf 05_24, findet das Makro Feiertage
- sollen die Feiertage nur für den einen Monat geprüft werden (Dann wäre die erste Version von mir richtig)
- oder für das restliche Jahr (dann die 2.)
- oder was genau soll mit der Feiertagsprüfung geschehen?


LG UweD
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 12:48:03
Unwissender
@UweD ich glaube es gibt da ein Missverständnis :D
mir geht es darum, das wenn ich jetzt z.B. das neue Blatt 01_27 benenne - da gibt es für das Jahr 2027 ja noch keine Einträge in dem Feiertag-Blatt.
Und genau dieser Fall soll abgefangen werden, dass man kein neues Blatt anlegen kann, wenn die Feiertagsliste für das anzulegende Jahr noch keinerlei Einträge hat.
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 14:45:24
Unwissender
@Hary, dein Code geht leider auch nicht, da bringt er einfach nie eine Meldung, ich kann auch 01_27 oder 04_30 anlegen als Blatt ohne das es eine Meldung gibt :(

Dachte es wäre etwas einfaches, eine Prüfung zu bauen, ob es für das neue angegebene Jahr überhaupt Einträge gibt in der Feiertag-liste (soll ja nur das Jahr prüfen, Monat prüfen geht ja schlecht da nicht jeder Monat Feiertage hat),
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 14:49:55
UweD
Hallo

Ok, jetzt hab ich es verstanden.
Dann so 

Private Sub CommandButton1_Click()



    Dim Datum As Date, wbname As String, RNG As Range

    

    Set RNG = Sheets("Feiertage").Columns("A") ' Spalte mit den Feiertagen

    

    ' Abfrage Monat und Jahr

    Datum = DateSerial(Year(Date), Month(Date) + 1, 1)

    

    wbname = InputBox("Name des neuen Blatts: mm_jj", "Blatt benennen", Format(Datum, "MM_YY"))

    

    'Abbrechen gedrückt

    If wbname = "" Then

        Exit Sub

    End If

    

    'Datum aus Eingabe erzeugen

    Datum = DateSerial(Right(wbname, 2) + 2000, Left(wbname, 2), 1)



    

    'Blatt schon vorhanden

    If Not IsError(Evaluate("'" & wbname & "'!A1")) Then ' Hochkomma wegen möglicher Leerzeichen

        MsgBox wbname & ": ist schon vorhanden"

                Exit Sub

    End If

    

    'Feiertage in dem Monat?

    If Datum > CDate(WorksheetFunction.Max(RNG)) Then

        MsgBox "Bitte erstmal die Feiertagsliste aktualisieren"

        Exit Sub

    End If

      

        

    ActiveSheet.Copy After:=Sheets(ActiveSheet.Index) 'Erstelle neues Blatt nach dem aktuell aktiven Blatt

    ActiveSheet.Name = wbname 'Benenne das neue Blatt wie in der Abfrage angegeben

    

    



    ' Blattschutz aufheben

    ActiveSheet.Unprotect



    'Schreibe Monat und Jahr in Zelle A3 des neuen Blattes

    ActiveSheet.Range("A3").FormulaR1C1 = Datum



    'entferne Einträge, Hintergrundfarbe und Kommentare in allen Zellen im Range Bereich die keine Formel enthalten

    On Error Resume Next

    With ActiveSheet.Range("D6:AH369").SpecialCells(xlCellTypeConstants)

        .ClearContents

        .ClearComments

        With .Interior

            .Pattern = xlNone

            .TintAndShade = 0

            .PatternTintAndShade = 0

        End With



        With .Font

            .Name = "Arial"

            .Size = 12

            .Strikethrough = False

            .Superscript = False

            .Subscript = False

            .OutlineFont = False

            .Shadow = False

            .Underline = xlUnderlineStyleNone

            .ThemeColor = xlThemeColorLight1

            .TintAndShade = 0

            .ThemeFont = xlThemeFontNone

        End With

    End With

    

    With ActiveSheet.Range("D6:AH369").SpecialCells(xlCellTypeBlanks)

        .ClearContents

        .ClearComments

        With .Interior

            .Pattern = xlNone

            .TintAndShade = 0

            .PatternTintAndShade = 0

        End With



        With .Font

            .Name = "Arial"

            .Size = 12

            .Strikethrough = False

            .Superscript = False

            .Subscript = False

            .OutlineFont = False

            .Shadow = False

            .Underline = xlUnderlineStyleNone

            .ThemeColor = xlThemeColorLight1

            .TintAndShade = 0

            .ThemeFont = xlThemeFontNone

        End With

    End With

    

    

    





    'mach die Datumsleiste wieder Blau

    Dim Zelle As Range

    For Each Zelle In ActiveSheet.Range("D6:AH369")

        If Zelle.HasFormula Then

            With Zelle.Interior

                .Pattern = xlSolid

                .PatternColorIndex = xlAutomatic

                .Color = 15773696

                .TintAndShade = 0

                .PatternTintAndShade = 0

            End With

         End If

    Next Zelle

    

    'markiere in oberer Datums-Zeile die Wochenenden und Feiertage und ziehe die Markierungen bis runter



        For Each Zelle In ActiveSheet.Range("D6:AH6")

            If IsDate(Zelle.Value) Then

                If WorksheetFunction.Weekday(Zelle.Value, 2) >= 6 Then

                      Zelle.Resize(364, 1).Interior.Color = 65535

                ElseIf WorksheetFunction.CountIf(Sheets("Feiertage").Range("A2:A34"), Zelle.Value) > 0 Then

                       Zelle.Resize(364, 1).Interior.Color = 39423

                Else

                End If

            End If

        Next Zelle





    'Springe in oberstes Feld (damit die User nicht erst hochscrollen müssen)

    ActiveSheet.Range("D7").Select



    'Blattschutz Aktivieren

    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=False, AllowFormattingCells:=True, AllowFiltering:=True



End Sub


LG UweD
Anzeige
AW: neues Monats-Blatt; Prüfen ob Jahr noch in Feiertragsblatt
06.03.2024 15:25:11
Unwissender
ES GEHT :) UweD ich danke dir vielmals für deine Zeit :) und vorallem hast du auch einzelne Codezeilen optimiert wie ich gesehen habe :D
Besten Dank dir :)

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige