RSS

Kalender i Excel med VBA

Denne side viser, hvordan man med VBA makroer lynhurtigt kan lave en kalender i Excel med et faneblad for hver måned og en kolonne for hver dag. Kan fx bruges til at holde styr på timeforbrug eller lignende.

Ved at bruge VBA's datofunktioer har makroen styr på, hvor mange dage der er i måneden, om det er skudår, hvornår der er weekend m.m.

Brugeren bestemmer selv, hvor mange rækker der skal være, men en mulighed er også en "timekalender," hvor der er 24 rækker for døgnets 24 timer (00-01, 01-02 osv.).

VBA-koden kan kopieres fra dene side, eller du kan downloade et zipkomprimeret regneark her. Det er lavet i Excel 2003, og kommentarerne er på engelsk.

Herunder ses et udsnit af kalenderen for januar 2016. Kolonner for lørdag og søndag har pastelgrøn fyldfarve.

Excel-kalender

Hvad jeg har brugt det til

På mit arbejde var det tidligere sådan, at man skulle holde regnskab med, hvor mange timer man brugte på forskellige projekter, og til det brugte jeg en kalender i Excel meget lig den, du kan lave med koden på denne side.

Jeg brugte den også til at holde styr på overtid, fridage, ferier og lignende.

Det var bare træls, når et nyt år startede, for så skulle langt de fleste weekends markeres på ny, og måske var det skudår. Det tog tid, så jeg lavede en makro, der bare skulle fodres med årstallet.

Kalenderkoden bruger bl.a. Ranges, et array, datofunktioner, inputboks og løkker.

Kalenderkoden

Der er to makroer i ét standardmodul. Den ene (Sub WithHours) bruges kun, hvis man vil have en kalender med 24 rækker for døgnets 24 timer. Den anden (Sub Calendar) laver selve kalenderen.

På modulniveau, altså øverst, deklareres to variable, som bruges af begge makroer.


Option Explicit
Dim bHours As Boolean         'True hvis 24 timer
Dim arHours(1 To 24, 1 To 1)  'Array til 24 timer

Her følger så proceduren, der laver kalenderen. Derefter følger proceduren Sub WithHours, der kaldes forinden, hvis man vil have en timekalender.

WithHours sætter bHours = True og udfylder arrayet arHours med timeintervaller (00-01, 01-02 osv.), som indsættes i kolonne C.


Sub Calendar()
Dim lCount As Long            'Tæller
Dim lNumber As Long           'Tæller
Dim lDays As Long             'Dage i måneden
Dim lFirstDayInMonth As Long  'Første dags nummer
Dim lMonth As Long
Dim lYear As Long
Dim lSat As Long              'Variabel for lørdag
Dim lSun As Long              'Variabel for søndag
Dim lRows As Long             'Antal rækker under overskrifter
Dim rRange As Range
Dim rCol As Range
Dim rHours As Range           'Range til timer
Dim vInput

On Error GoTo ErrorHandle

'Bed brugeren om et årstal
vInput = InputBox("Årstal?", "Indsæt årstal")

'Hvis brugeren valgte Cancel
If vInput = Empty Then GoTo BeforeExit

'Hvis det ikke er et tal eller <> 4 cifre
If IsNumeric(vInput) = False Or Len(vInput) <> 4 Then
   MsgBox "Ikke et gyldigt årstal"
   GoTo BeforeExit
End If

'Slår skærmopdatering fra for hastighed
Application.ScreenUpdating = False

lYear = vInput

If bHours Then
   lRows = 23
Else
   'Spørg brugeren om antal rækker
   vInput = InputBox("Antal rækker til indtastning?", "Indsæt tal")
   If IsNumeric(vInput) = False Then
      MsgBox "Ikke et gyldigt antal rækker"
      GoTo BeforeExit
   End If
   If vInput > Rows.Count - 1 Then
      MsgBox "For mange rækker"
      GoTo BeforeExit
   End If
   If vInput <= 0 Then
      MsgBox "Der skal være mindst 1 række"
      GoTo BeforeExit
   End If
   lRows = vInput - 1
End If


'Åbn en ny Workbook til kalenderen
Workbooks.Add

'Idet vi antager, at nye regneark stadig
'har 3 faneblade, tilføjer vi 9 mere, så
'der er et for hver måned i året.
With Worksheets
   For lCount = 1 To 9
      .Add
   Next
End With

'Navngiv fanerne. Hvis du ikke ønsker store bogstaver,
'fjerner du bare "UCase" og et sæt parenteser "()".
'Ved at bruge strengfunktionen "Left" og 3, bruger
'vi kun de første 3 karakterer i månedens navn,
'fx JAN for januar.
With Worksheets
   For lCount = 1 To 12
      .Item(lCount).Name = UCase(Left(MonthName(lCount), 3))
   Next
End With

'Nu gennemløber vi de 12 faner og formaterer kalenderen
'for hver måned med det rette antal dage osv.
For lCount = 1 To 12
   Worksheets.Item(lCount).Activate
   
   'Find antal dage i måneden
   Select Case lCount
      'Jan, Marts, Maj etc.
      Case 1, 3, 5, 7, 8, 10, 12
         lDays = 31
      'Februar
      Case 2
         If IsDate("29/2/" & lYear) = False Then
            lDays = 28
         Else
            lDays = 29  'Skudår
         End If
      Case Else
         lDays = 30
   End Select
   
   'Find den første dag i måneden.
   lFirstDayInMonth = DateSerial(lYear, lCount, 1)
   
   'Find ugedagsnummeret for månedens første dag.
   'Det bruger vi senere til at finde kolonnerne
   'med weekends.
   'Ugedagsnummeret er 1 for mandag, 2 for tirsdag osv.
   lFirstDayInMonth = Weekday(lFirstDayInMonth, vbMonday)
   
   'Overskrifter for kolonne A til C.
   'Dem kan du ændre, som du vil.
   Range("A1").Value = "Projekter"
   Range("B1").Value = "Tekst"
   If bHours Then
      Range("C1").Value = "Time"
   Else
      Range("C1").Value = "Dato"
   End If
   
   'Datoerne indsættes fra venstre mod højre med
   'en kolonne for hver dag.
   For lNumber = 1 To lDays
      Range("C1").Offset(0, lNumber).Value = lNumber
   Next
   
   'Tilføj "Sum" som overskrift i kolonnen efter
   'den sidste dag.
   Range("C1").Offset(0, lDays + 1).Value = "Sum"
   
   'Indsæt SUM-formel i kolonnen til højre for
   'den sidste dag. Det kan fx være summen af
   'timer brugt på forskellige projekter eller
   'andet - alt efter hvad man bruger kalenderen til.
   For lNumber = 2 To lRows + 2
      Set rRange = Range("D" & lNumber)
      Set rRange = Range(rRange, rRange.Offset(0, lDays - 1))
      Range("D" & lNumber).Offset(0, lDays).Formula = _
      "=sum(" & rRange.Address & ")"
   Next
   
   'Weekend-kode.
   'Vi finder kolonnerne med lørdage og søndage og
   'farver dem grønne. Det kan du selvfølgelig
   'skippe, eller du kan vælge en anden farve.
   'Antallet af rækker blev defineret tidligere.
   lNumber = 0
   Set rRange = Range(Range("D2"), Range("D2").Offset(0, lDays))
   'Gennemløb dagene i måneden.
   Do Until lNumber > lDays
      lNumber = lNumber + 7
      lSat = lNumber - lFirstDayInMonth      'Lørdag
      lSun = lNumber + 1 - lFirstDayInMonth  'Søndag
      
      'Hvis lørdagens månedsnummer er > 0 og mindre
      'end antal dage i måneden, er det lørdags-
      'kolonnen, og søndagskolonnen er +1.
      If lSat > 0 And lSat < lDays Then
         Set rCol = rRange.Item(lSat)
         Set rCol = Range(rCol, rCol.Offset(lRows, 1))
      End If
      
      'Hvis lørdagen er månedens sidste dag
      If lSat = lDays Then
         Set rCol = rRange.Item(lSat)
         Set rCol = Range(rCol, rCol.Offset(lRows, 0))
      End If
      
      'Hvis søndagen er månedens første dag
      If lSun = 1 Then
         Set rCol = rRange.Item(1)
         Set rCol = Range(rCol, rCol.Offset(lRows, 0))
      End If
      
      'Formaterer weekend-kolonnen
      With rCol.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ColorIndex = 35   'Brug den farve, du vil
      End With
   Loop
   'Slut weekend-kode
   
   With Range(rRange, rRange.Offset(lRows, 0))
      'Sæt kolonnebredden som du vil
      .ColumnWidth = 4.09
      .HorizontalAlignment = xlCenter
   End With
   
   'Centrerer datoerne
   Range(rRange, rRange.Offset(-1)).HorizontalAlignment = xlCenter
   
   'Skriv timetal i kolonne C, hvis det er en kalender
   'med timetal.
   If bHours Then
      Set rHours = Range(Range("C2"), Range("C25"))
      With rHours
         'Formatér cellerne som tekst
         .NumberFormat = "@"
         'Centrerer
         .HorizontalAlignment = xlCenter
         'Kopierer array til cellerne
         .Value = arHours
      End With
   End If
   
   Set rRange = Range(rRange.Offset(0, -3), rRange.Offset(lRows, 0))
   
   'Sæt bredden på kolonne A og B
   With Columns
      .Item(1).ColumnWidth = 25
      .Item(2).ColumnWidth = 25
   End With
    
   'Cellekanter
   With rRange
      .Borders(xlDiagonalDown).LineStyle = xlNone
      .Borders(xlDiagonalUp).LineStyle = xlNone
   End With
   With rRange.Borders(xlEdgeLeft)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   With rRange.Borders(xlEdgeTop)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   With rRange.Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   With rRange.Borders(xlEdgeRight)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   With rRange.Borders(xlInsideVertical)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   With rRange.Borders(xlInsideHorizontal)
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .Weight = xlThin
   End With
   ActiveWindow.Zoom = 80
   Columns("C").AutoFit
Next

BeforeExit:
Set rRange = Nothing
Set rCol = Nothing
Set rHours = Nothing
bHours = False
Worksheets(1).Activate
Application.ScreenUpdating = True

Exit Sub
ErrorHandle:
MsgBox Err.Description
Resume BeforeExit
End Sub

Nu følger koden i proceduren WithHours, der kaldes som den første, hvis man vil lave en kalender med 24 rækker for døgnets 24 timer.

Den sætter bHours til True, og udfylder arrayet arHours med timeintervaller, inden den kalder proceduren Calendar.


Sub WithHours()
Dim lCount As Long

'Sæt flag for at det er en kalender med
'24 rækker og timer (intervaller).
bHours = True

'Fyld arrayet med timeintervaller,
'som senere kopieres til kolonne C.
For lCount = 0 To 8
   arHours(lCount + 1, 1) = "0" & lCount & "-" & "0" & lCount + 1
Next

arHours(10, 1) = "09-10"

For lCount = 10 To 23
   arHours(lCount + 1, 1) = lCount & "-" & lCount + 1
Next

'Kalder kalenderproceduren
Calendar

End Sub

Det var det: en kalender i Excel. Koden kan forholdsvis enkelt modificeres. Fx kan cellerne i kolonne A og B udfyldes automatisk med projektnavne, medarbejdere eller hvad ved jeg.

Du kan kopiere koden på denne side ved at markere den med musen, kopiere den med CTRL+C og indsætte den i et VBA-modul med CTRL+V.

Eller du kan downloade et zipkomprimeret regneark med koden og to trykknapper til at køre den.

God fornøjelse!


Relateret: