17. februar 2009 - 14:55Der er
1 kommentar og 1 løsning
Hjælp til min projektkalender
Hej Eksperten.dk
Dette er mit første spørgsmål på denn side, så hvis jeg nu skrive noget som ikke er standard, så er det begynder fejl.
Jeg har fundet en kalender på nettet. Her kan man indtaster et årstal, her ud fra dannes nu en kalender via en makro.
Kalenderen er 3 felter par dato i mdr. første har ugedag, anden har dato, tredje er et muligt skrivefelt. Dette skrivefelt vil jeg gerne lave sådan at jeg efter indtastning af år også indtaster antal medarbejder. Jeg vil derfor gerne have gjort feltet mindre og delt op i X antal af hvormange medarbejder der tastes.
Nu kommer mit problem så jeg kan ikke huske hvor jeg har dl denne makroen. Så ér der en der har mega styr på makroer, vil jeg meget gerne høre fra person her i forumet eller via mail sirbubber@gmail.com
Function Påskedag(InputYear As Integer) As Long ' Returnerer datoen for Påskedag Dim d As Integer d = (((255 - 11 * (InputYear Mod 19)) - 21) Mod 30) + 21 Påskedag = DateSerial(InputYear, 3, 1) + d + (d > 48) + 6 - _ ((InputYear + InputYear \ 4 + d + (d > 48) + 1) Mod 7) End Function
Function HelligdagsNavn(lngdate As Long) As String ' bruger funktionen Påskedag Dim InputYear As Integer, PD As Long, OK As Boolean If lngdate <= 0 Then lngdate = Date InputYear = Year(lngdate) PD = Påskedag(InputYear) OK = True Select Case lngdate ' Tester nedenstående påstande mod datoen Case DateSerial(InputYear, 1, 1): HelligdagsNavn = "*" Case PD - 3: HelligdagsNavn = "*" Case PD - 2: HelligdagsNavn = "*" Case PD: HelligdagsNavn = "*" Case PD + 1: HelligdagsNavn = "*" Case DateSerial(InputYear, 6, 5): HelligdagsNavn = "*" Case PD + 26: HelligdagsNavn = "*" Case PD + 39: HelligdagsNavn = "*" Case PD + 49: HelligdagsNavn = "*" Case PD + 50: HelligdagsNavn = "*" Case DateSerial(InputYear, 12, 24): HelligdagsNavn = "*" Case DateSerial(InputYear, 12, 25): HelligdagsNavn = "*" Case DateSerial(InputYear, 12, 26): HelligdagsNavn = "*" Case DateSerial(InputYear, 12, 31): HelligdagsNavn = "*" Case Else End Select OK = False End Function Public Sub Kalender() Dim År As Integer, Dato As Date, DD As Long, Md As Variant, Dag As Variant, HD As String Md = Array("", "Januar", "Febuar", "Marts", "April", "Maj", "Juni", "Juli", "August", "September", "Oktober", "November", "December") Dag = Array("", "S", "M", "T", "O", "T", "F", "L") År = InputBox(" Indtast årstal for kalender") Antal = InputBox(" Indtast antal medarbejder") Application.ScreenUpdating = False Cells.MergeCells = False Range("A1") = "" Range("A1:R1").Interior.ColorIndex = 50 Range("A2:R2").Interior.ColorIndex = 38 For a = 1 To 7 Cells(2, a * 3) = Md(a) Next Dato = "01-01-" & År For K = 1 To 18 Step 3 Call MDRamme(K, 2) Olddato = Dato For I = 3 To 33 DD = DateValue(Dato) HD = HelligdagsNavn(DD) Cells(I, K) = Dag(Weekday(Dato)) Select Case Weekday(Dato) Case 1, 7 Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 15 Cells(I, K + 2) = HD Case 2 Cells(I, K + 2) = "" Cells(I, K + 2) = "'" & DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HD If HD = "" Then Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40 End If Case Else Cells(I, K + 2) = HD If HD = "" Then Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40 End If End Select Cells(I, K + 1) = Day(Dato) HD = "" Dato = Dato + 1 If Month(Dato) <> Month(Olddato) Then Exit For Next Next
' -----------------næste halve år ------------- Range("A34:R34").Interior.ColorIndex = 38 For a = 7 To 12 Cells(34, (a - 6) * 3) = Md(a) Next For K = 1 To 18 Step 3 Call MDRamme(K, 34) For I = 35 To 65 Olddato = Dato DD = DateValue(Dato) HD = HelligdagsNavn(DD) Cells(I, K) = Dag(Weekday(Dato)) Select Case Weekday(Dato) Case 1, 7 Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 15 Cells(I, K + 2) = HD Case 2 Cells(I, K + 2) = "'" & DatePart("ww", Dato, vbMonday, vbFirstFourDays) & " " & HD If HD = "" Then Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40 End If Case Else Cells(I, K + 2) = HD If HD = "" Then Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = xlNone Else Range(Cells(I, K), Cells(I, K + 2)).Interior.ColorIndex = 40 End If End Select HD = "" Cells(I, K + 1) = Day(Dato) Dato = Dato + 1 If Month(Dato) <> Month(Olddato) Then Exit For Next Next Range("A1:R65").Select Range("R65").Activate Range("A3:R33,A35:R65").Font.Size = 7 Range("A3:R33,A35:R65").Borders.LineStyle = xlContinuous Columns("A:R").Select Columns("A:R").EntireColumn.AutoFit
Range("C:C,F:F,I:I,L:L,O:O,R:R").ColumnWidth = 10
Rows("34:34").Select ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell Range("3:33,35:65").RowHeight = 12 ActiveSheet.PageSetup.PrintTitleRows = "$1:$1" With ActiveSheet.PageSetup .Orientation = xlLandscape .Zoom = 100 .TopMargin = Application.InchesToPoints(1) .BottomMargin = Application.InchesToPoints(0) .HeaderMargin = Application.InchesToPoints(0) .FooterMargin = Application.InchesToPoints(0) End With Range("A1:R1").Merge Range("A1:R1").Borders.LineStyle = xlContinuous Range("A1:R1").HorizontalAlignment = xlCenter Range("A1") = År Range("A1").Select Application.ScreenUpdating = True End Sub Sub MDRamme(KO, RK) Range(Cells(RK, KO), Cells(RK, KO + 2)).Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With Selection.Borders(xlInsideVertical).LineStyle = xlNone End Sub
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.