automatisk navngivning af faneblade.

Helligdage skal altså ikke med? - men ellers skulle det ikke være det store problem.

Vender tilbage...

Koden ligger i en userform, hvor måned & år kan vælges:

Hele filen kan returneres ved mail til: pb@supertekst-it.dk
============================================================

Dim xDato As Date, denSidsteDenneMåned As Date
Dim xMdDage

Dim måneder As Variant, mdDage As Variant, dgNavn As Variant

Rem HelligDage
Dim påskedag
Dim fhDageNavn As Variant
Dim fhDageDato As Variant

Dim vhDageNavn As Variant
Dim vhDageDato As Variant
Private Sub CommandButton1_Click()                  'ok
Dim arkNr

    Application.ScreenUpdating = False
   
    opbygMåneden
    påskedag = beregnPåske(Year(xDato))
    opsætningAfHelligDage påskedag
   
    Application.DisplayAlerts = False
   
    While ActiveWorkbook.Sheets.Count > 1
        ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count).Delete
    Wend
   
    arkNr = 1
   
    For dag = 1 To xMdDage
           
Rem beregn om lørdag/søndag eller helligdag
        dagnr = DatePart("w", xDato, 2, 2)

        If Not (erDetHelligdag(Format(xDato, "dd-mm")) <> "" Or dagnr > 5) Then
            If arkNr > 1 Then
                ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.Count)
            End If
            ActiveWorkbook.Sheets(arkNr).Name = xDato
            arkNr = arkNr + 1
        End If
       
        xDato = DateAdd("d", 1, xDato)
    Next dag

   
    ActiveWorkbook.SaveAs Filename:= _
        InputSti & Me.ComboBox1 + " " + Me.TextBox1 & ".xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
           
    Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click()                  'annuller
    Unload UserForm1
End Sub
Private Sub SpinButton1_SpinUp()
    Me.TextBox1 = CStr(Val(Me.TextBox1) + 1)
End Sub
Private Sub SpinButton1_SpinDown()
    Me.TextBox1 = CStr(Val(Me.TextBox1) - 1)
End Sub
Private Sub UserForm_activate()
    housekeeping
End Sub
Private Sub housekeeping()
    måneder = Array("Januar", "Februar", "Marts", "April", "Maj", "Juni", "Juli", "August", "September", "Oktober", "November", "December")
   
    Me.ComboBox1.Clear
   
    For m = 0 To 11
        Me.ComboBox1.AddItem måneder(m)
    Next m
   
    Me.ComboBox1.ListIndex = Month(Now) - 1
   
    Me.TextBox1 = Year(Now)
End Sub
Private Sub opbygMåneden()
    xDato = "01" + "-" + CStr(Me.ComboBox1.ListIndex + 1) + "-" + Me.TextBox1
    OpsætDatoVærdier xDato
End Sub
Private Sub OpsætDatoVærdier(dato As Date)
Dim wdato As Date, wDag
    dgNavn = Array("", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag", "Søndag")
    mdDage = Array(, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

Rem Månedsnavn
    xMd = Month(dato)
    aktuelleMåned = xMd
   
Rem Antal dage i måned
Rem test skudår
    xÅr = Year(dato)
    If xMd = 2 Then
        If xÅr Mod 4 = 0 Then
            xMdDage = 29
        Else
            xMdDage = 28
        End If
    Else
        xMdDage = mdDage(xMd)
    End If
   
    denSidsteDenneMd = CStr(xMdDage) + "-" + CStr(xMd) + "-" + CStr(xÅr)
   
Rem Ugedag for den 1.
    wDag = Day(dato)
    If wDag > 1 Then
        wdato = DateAdd("d", (wDag - 1) * -1, dato)
    Else
        wdato = dato
    End If
   
    xDgNr = DatePart("w", wdato, 2, 2)
    xUgeNr = DatePart("ww", wdato, 2, 2)
End Sub
Public Function beregnPåske(aar)

Rem Beregning af Paaske - 1900 - 2099
Rem =================================
Dim d, E, Q
    b1 = aar Mod 19
    d = 225 - (11 * b1)
   
    If d > 50 Then
        While d > 50
            d = d - 30
        Wend
    End If
   
    If d > 48 Then
        d = d - 1
    End If
   
    E = (aar + Int(aar / 4) + d + 1) Mod 7
   
    Q = d + 7 - E
   
    If Q < 32 Then
        m = "03"
    Else
        m = "04"
        Q = Q - 31
    End If
   
    beregnPåske = CStr(Q) + "-" + m + "-" + CStr(aar)
End Function
Public Sub opsætningAfHelligDage(påskedag)
Rem Faste
    fhDageNavn = Array("Nytårsdag", "Grundlovsdag", "Juleaften", "Juledag", "2. Juledag", "Nytårsaften")
    fhDageDato = Array("01-01", "05-06", "24-12", "25-12", "26-12", "31-12")

Rem Variable
    vhDageNavn = Array("Skærtorsdag", "Langfredag", "Påskedag", "2. Påskedag", "St. Bededag", "Kr. Himmelfart", "Pinsedag", "2. Pinsedag")
    vhDageDato = Array("", "", "", "", "", "", "", "")

Rem Skærtorsdag
    vhDageDato(0) = Format(DateAdd("d", -3, påskedag), "dd-mm")
   
Rem Langfredag
    vhDageDato(1) = Format(DateAdd("d", -2, påskedag), "dd-mm")

Rem Påskedag
    vhDageDato(2) = Format(påskedag, "dd-mm")

Rem 2. Påskedag
    vhDageDato(3) = Format(DateAdd("d", 1, påskedag), "dd-mm")

Rem St. Bededag
    vhDageDato(4) = Format(DateAdd("ww", 4, vhDageDato(1)), "dd-mm")
   
Rem Kr. Himmelfart
    vhDageDato(5) = Format(DateAdd("ww", 6, vhDageDato(0)), "dd-mm")
   
Rem Pinsedag
    vhDageDato(6) = Format(DateAdd("ww", 7, påskedag), "dd-mm")

Rem 2. Pinsedag
    vhDageDato(7) = Format(DateAdd("d", 1, vhDageDato(6)), "dd-mm")
End Sub
Public Function erDetHelligdag(dato)                'returnerer helligdagens navn
Dim f
Rem Faste helligdage
    For f = 0 To 5
        If fhDageDato(f) = dato Then
            erDetHelligdag = fhDageNavn(f)
            Exit Function
        End If
    Next f

Rem Variable
    For f = 0 To 7
        If vhDageDato(f) = dato Then
            erDetHelligdag = vhDageNavn(f)
            Exit Function
        End If
    Next f
   
    erDetHelligdag = ""
End Function

Version 2 - hvor indholdet i Ark1 kopieres over i alle oprettede faner med månedens hverdage:

Dim xDato As Date, denSidsteDenneMåned As Date
Dim xMdDage

Dim måneder As Variant, mdDage As Variant, dgNavn As Variant

Rem HelligDage
Dim påskedag
Dim fhDageNavn As Variant
Dim fhDageDato As Variant

Dim vhDageNavn As Variant
Dim vhDageDato As Variant
Private Sub CommandButton1_Click()                  'ok
Dim arkNr

    Application.ScreenUpdating = False
   
    opbygMåneden
    påskedag = beregnPåske(Year(xDato))
    opsætningAfHelligDage påskedag
   
    Application.DisplayAlerts = False
   
    While ActiveWorkbook.Sheets.Count > 1
        ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count).Delete
    Wend
   
    arkNr = 1
   
    For dag = 1 To xMdDage
           
Rem beregn om lørdag/søndag eller helligdag
        dagnr = DatePart("w", xDato, 2, 2)

        If Not (erDetHelligdag(Format(xDato, "dd-mm")) <> "" Or dagnr > 5) Then
            If arkNr > 1 Then
                Sheets(1).Select
                Sheets(1).Copy After:=Worksheets(Worksheets.Count)
            End If
            ActiveWorkbook.Sheets(arkNr).Name = xDato
            arkNr = arkNr + 1
        End If
       
        xDato = DateAdd("d", 1, xDato)
    Next dag

   
    ActiveWorkbook.SaveAs Filename:= _
        InputSti & Me.ComboBox1 + " " + Me.TextBox1 & ".xls", FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
           
    Application.ScreenUpdating = True
   
    Unload UserForm1
End Sub
Private Sub CommandButton2_Click()                  'annuller
    Unload UserForm1
End Sub
Private Sub SpinButton1_SpinUp()
    Me.TextBox1 = CStr(Val(Me.TextBox1) + 1)
End Sub
Private Sub SpinButton1_SpinDown()
    Me.TextBox1 = CStr(Val(Me.TextBox1) - 1)
End Sub
Private Sub UserForm_activate()
    housekeeping
End Sub
Private Sub housekeeping()
    måneder = Array("Januar", "Februar", "Marts", "April", "Maj", "Juni", "Juli", "August", "September", "Oktober", "November", "December")
   
    Me.ComboBox1.Clear
   
    For m = 0 To 11
        Me.ComboBox1.AddItem måneder(m)
    Next m
   
    Me.ComboBox1.ListIndex = Month(Now) - 1
   
    Me.TextBox1 = Year(Now)
End Sub
Private Sub opbygMåneden()
    xDato = "01" + "-" + CStr(Me.ComboBox1.ListIndex + 1) + "-" + Me.TextBox1
    OpsætDatoVærdier xDato
End Sub
Private Sub OpsætDatoVærdier(dato As Date)
Dim wdato As Date, wDag
    dgNavn = Array("", "Mandag", "Tirsdag", "Onsdag", "Torsdag", "Fredag", "Lørdag", "Søndag")
    mdDage = Array(, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)

Rem Månedsnavn
    xMd = Month(dato)
    aktuelleMåned = xMd
   
Rem Antal dage i måned
Rem test skudår
    xÅr = Year(dato)
    If xMd = 2 Then
        If xÅr Mod 4 = 0 Then
            xMdDage = 29
        Else
            xMdDage = 28
        End If
    Else
        xMdDage = mdDage(xMd)
    End If
   
    denSidsteDenneMd = CStr(xMdDage) + "-" + CStr(xMd) + "-" + CStr(xÅr)
   
Rem Ugedag for den 1.
    wDag = Day(dato)
    If wDag > 1 Then
        wdato = DateAdd("d", (wDag - 1) * -1, dato)
    Else
        wdato = dato
    End If
   
    xDgNr = DatePart("w", wdato, 2, 2)
    xUgeNr = DatePart("ww", wdato, 2, 2)
End Sub
Public Function beregnPåske(aar)

Rem Beregning af Paaske - 1900 - 2099
Rem =================================
Dim d, E, Q
    b1 = aar Mod 19
    d = 225 - (11 * b1)
   
    If d > 50 Then
        While d > 50
            d = d - 30
        Wend
    End If
   
    If d > 48 Then
        d = d - 1
    End If
   
    E = (aar + Int(aar / 4) + d + 1) Mod 7
   
    Q = d + 7 - E
   
    If Q < 32 Then
        m = "03"
    Else
        m = "04"
        Q = Q - 31
    End If
   
    beregnPåske = CStr(Q) + "-" + m + "-" + CStr(aar)
End Function
Public Sub opsætningAfHelligDage(påskedag)
Rem Faste
    fhDageNavn = Array("Nytårsdag", "Grundlovsdag", "Juleaften", "Juledag", "2. Juledag", "Nytårsaften")
    fhDageDato = Array("01-01", "05-06", "24-12", "25-12", "26-12", "31-12")

Rem Variable
    vhDageNavn = Array("Skærtorsdag", "Langfredag", "Påskedag", "2. Påskedag", "St. Bededag", "Kr. Himmelfart", "Pinsedag", "2. Pinsedag")
    vhDageDato = Array("", "", "", "", "", "", "", "")

Rem Skærtorsdag
    vhDageDato(0) = Format(DateAdd("d", -3, påskedag), "dd-mm")
   
Rem Langfredag
    vhDageDato(1) = Format(DateAdd("d", -2, påskedag), "dd-mm")

Rem Påskedag
    vhDageDato(2) = Format(påskedag, "dd-mm")

Rem 2. Påskedag
    vhDageDato(3) = Format(DateAdd("d", 1, påskedag), "dd-mm")

Rem St. Bededag
    vhDageDato(4) = Format(DateAdd("ww", 4, vhDageDato(1)), "dd-mm")
   
Rem Kr. Himmelfart
    vhDageDato(5) = Format(DateAdd("ww", 6, vhDageDato(0)), "dd-mm")
   
Rem Pinsedag
    vhDageDato(6) = Format(DateAdd("ww", 7, påskedag), "dd-mm")

Rem 2. Pinsedag
    vhDageDato(7) = Format(DateAdd("d", 1, vhDageDato(6)), "dd-mm")
End Sub
Public Function erDetHelligdag(dato)                'returnerer helligdagens navn
Dim f
Rem Faste helligdage
    For f = 0 To 5
        If fhDageDato(f) = dato Then
            erDetHelligdag = fhDageNavn(f)
            Exit Function
        End If
    Next f

Rem Variable
    For f = 0 To 7
        If vhDageDato(f) = dato Then
            erDetHelligdag = vhDageNavn(f)
            Exit Function
        End If
    Next f
   
    erDetHelligdag = ""
End Function

Den virker helt efter hensigten - super - tak for det :o)
mvh.
Hubertus