"Evigheds-kalender"

Hvordanvil du have datoerne.. i en lang række efter hinanden?

Sub workbook_activate()
Dim dato As Date, måned, år, antalÅr
Dim r, k
    r = 1
Rem Tag udgangspunkt i aktuelle dato
    dato = Now

Rem sæt antal år
    antalÅr = 5
    stopdato = DateAdd("YYYY", antalÅr, dato)
   
    While dato < stopdato
        Cells(r, 1).Value = dato
        Cells(r, 2).Value = hentUgedag(dato)
       
Rem tæl dato 1 dag frem
        dato = DateAdd("d", 1, dato)
        r = r + 1
    Wend

    MsgBox ("Kaldenderopbygning afsluttet")
End Sub
Private Function hentUgedag(dato)
Dim Dnavn(1 To 7)
    Dnavn(1) = "Man"
    Dnavn(2) = "Tir"
    Dnavn(3) = "Ons"
    Dnavn(4) = "Tor"
    Dnavn(5) = "Fre"
    Dnavn(6) = "Lør"
    Dnavn(7) = "Søn"

    hentUgedag = Dnavn(DatePart("w", dato, 2, 2))
End Function

se evt denne. her kan du bare ændre årstallet i toppen.
http://www.tbdl.dk/excel/kalender1.xls

eller hele dette spm.
http://www.eksperten.dk/spm/667095

Jeg vil gerne have følgende i kolonner
A            B         
Ugedag      Dato

Og hvis der kunne lade sig gøre , 1 mdr på hvert regneark ?

Public Sub SerieKalender()
Application.ScreenUpdating = False
Dim I As Date, II As Date, Ark As String
StartAAr = InputBox("Indtast Startår")
SlutAAr = InputBox("Indtast Slutår")

  I = "01-01-" & StartAAr
  II = "31-12-" & SlutAAr
  For I = I To II
  Ark = Format(I, "mmm-yyyy", vbMonday, vbFirstFourDays)
  If Not (SheetExists(Ark)) Then
'laver ny
  Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
  ActiveSheet.Name = Ark
  Worksheets(Ark).Cells(1, 1) = "Dag"
  Worksheets(Ark).Cells(1, 1) = "Dato"
  Else
Worksheets(Ark).Cells(Day(I) + 1, 1) = Format(I, "dddd", vbMonday, vbFirstFourDays)
Worksheets(Ark).Cells(Day(I) + 1, 2) = I
  End If
  Next

  Application.ScreenUpdating = True
End Sub
Function SheetExists(IBox As String) As Boolean
' returnerer TRUE dersom arket finnes i den aktive arbeidsboken
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(Sheets(IBox).Name) > 0 Then
        SheetExists = True
        Exit Function
    End If
NoSuchSheet:
End Function

der var en smutter, nu skulle den være ok

ublic Sub SerieKalender()
Application.ScreenUpdating = False
Dim I As Date, II As Date, Ark As String
StartAAr = InputBox("Indtast Startår")
SlutAAr = InputBox("Indtast Slutår")

  I = "01-01-" & StartAAr
  II = "31-12-" & SlutAAr
  For I = I To II
  Ark = Format(I, "mmm-yyyy", vbMonday, vbFirstFourDays)
  If Not (SheetExists(Ark)) Then
    'laver ny
    Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Ark
    Worksheets(Ark).Cells(1, 1) = "Dag"
    Worksheets(Ark).Cells(1, 2) = "Dato"
    Worksheets(Ark).Cells(Day(I) + 1, 1) = Format(I, "dddd", vbMonday, vbFirstFourDays)
    Worksheets(Ark).Cells(Day(I) + 1, 2) = I
  Else
    Worksheets(Ark).Cells(Day(I) + 1, 1) = Format(I, "dddd", vbMonday, vbFirstFourDays)
    Worksheets(Ark).Cells(Day(I) + 1, 2) = I
  End If
  Next

  Application.ScreenUpdating = True
End Sub
Function SheetExists(IBox As String) As Boolean
' returnerer TRUE dersom arket finnes i den aktive arbeidsboken
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(Sheets(IBox).Name) > 0 Then
        SheetExists = True
        Exit Function
    End If
NoSuchSheet:
End Function

Super, mennnn hvordan får temmelig uvidende newbii som mig dette over i et exel-regneark
føler mig lidt "dum"

tryk ALT + F11

nu er du i VBA editoren

Vælg insert module

Kopier dette derind



Public Sub SerieKalender()
Application.ScreenUpdating = False
Dim I As Date, II As Date, Ark As String
StartAAr = InputBox("Indtast Startår")
SlutAAr = InputBox("Indtast Slutår")

  I = "01-01-" & StartAAr
  II = "31-12-" & SlutAAr
  For I = I To II
  Ark = Format(I, "mmm-yyyy", vbMonday, vbFirstFourDays)
  If Not (SheetExists(Ark)) Then
    'laver ny
    Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = Ark
    Worksheets(Ark).Cells(1, 1) = "Dag"
    Worksheets(Ark).Cells(1, 2) = "Dato"
    Worksheets(Ark).Cells(Day(I) + 1, 1) = Format(I, "dddd", vbMonday, vbFirstFourDays)
    Worksheets(Ark).Cells(Day(I) + 1, 2) = I
  Else
    Worksheets(Ark).Cells(Day(I) + 1, 1) = Format(I, "dddd", vbMonday, vbFirstFourDays)
    Worksheets(Ark).Cells(Day(I) + 1, 2) = I
  End If
  Next

  Application.ScreenUpdating = True
End Sub
Function SheetExists(IBox As String) As Boolean
' returnerer TRUE dersom arket finnes i den aktive arbeidsboken
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(Sheets(IBox).Name) > 0 Then
        SheetExists = True
        Exit Function
    End If
NoSuchSheet:
End Function


Luk nu på øverste X i højre hjørne, så er du tilbage på arket

Funktioner > Makro > Makroer, vælg SerieKalender og  afspil

Super det var lige det jeg havde brug for
send svar kabbak, så får du lidt for hjælpen

Takker

et svar ;-))

tak for point ;-))