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

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

Beliebteste Forumthreads (12 Monate)

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

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

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

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread