Kalender og 53 uger
Har et ark hvor man kan skrive nogle datoer ind og så viser den området mellem de to datoer.Når den viser det område, ligger henter den nogle data på en anden fane i arket, som den så ligger ind i det område som man har valgt at den skal vise.
Men den skifter fra uge 53 til uge 2 her til årsskiftet....
Jeg har ikke selv lavet det, men tror det er den VBA her, der laver kalenderen.
Nogen der ved hvor den er gal, vedr. de med 53 uger?
Sub Lav_Kalender_Ny()
Dim ws3 As Worksheet, ws1 As Worksheet
Dim NumDates As Integer, ColumnCount As Integer, LWeekday As Integer, Count As Integer, LWeek As Integer, ThisMonth As Integer, FirstMonth As Integer, RemainderOfPeriode As Integer, OldPeriodColumnCount As Integer
Dim LDate As Date, FirstDate As Date
Dim months(12) As String
Dim VDate As Boolean
Set ws3 = Sheets("Vis_Oversigt")
Set ws1 = Sheets("Indtastningsark")
VDate = IsDate(Range("C4"))
If VDate = False Then
MsgBox ("Start datoen er ikke en gyldig dato")
Exit Sub
End If
VDate = IsDate(Range("E4"))
If VDate = False Then
MsgBox ("Slut datoen er ikke en gyldig dato")
Exit Sub
End If
If ws3.Cells(4, 6) > 400 Then
MsgBox ("Venligst vµlg en periode pÕ max 400 dage")
Exit Sub
End If
If ws3.Cells(4, 6) < 0 Then
MsgBox ("Din slut dato(PeriodeSlut) er f°r din start dato(PeriodeStart)")
Exit Sub
End If
ActiveSheet.Unprotect Password:="5980"
ws3.Cells.Borders.LineStyle = xlLineStyleNone
Count = ws3.Range("B" & Rows.Count).End(xlUp).Row 'Finder antallet af indf°rte rµkker pÕ sheet Vis_Oversigt
Count = Count + 1
OldPeriodColumnCount = ws1.Cells(11, 26)
Range(Cells(1, 10), Cells(4, OldPeriodColumnCount + 10)).UnMerge
Range(Cells(1, 10), Cells(Count, OldPeriodColumnCount + 10)).ClearContents
Range(Cells(1, 10), Cells(Count, OldPeriodColumnCount + 10)).ColumnWidth = 8.43
Range(Cells(1, 10), Cells(Count, OldPeriodColumnCount + 10)).Interior.ColorIndex = xlNone
NumDates = ws3.Cells(4, "F").Value
ColumnCount = NumDates + 10
months(1) = "Jan"
months(2) = "Feb"
months(3) = "Mar"
months(4) = "Apr"
months(5) = "MaJ"
months(6) = "Jun"
months(7) = "Jul"
months(8) = "Aug"
months(9) = "Sep"
months(10) = "Okt"
months(11) = "Nov"
months(12) = "Dec"
For j = 10 To ColumnCount
ws3.Columns(j).ColumnWidth = 1
Next j
LDate = ws3.Cells(4, "C").Value
FirstDate = LDate
For j = 10 To ColumnCount
ws3.Range(Cells(3, 10), Cells(1, ColumnCount)).HorizontalAlignment = xlCenter
ws3.Range(Cells(4, 10), Cells(2, ColumnCount)).HorizontalAlignment = xlCenter
ws3.Range(Cells(5, 10), Cells(3, ColumnCount)).HorizontalAlignment = xlCenter
LWeekday = WeekDay(LDate, vbMonday)
LWeek = WorksheetFunction.WeekNum(LDate, vbSunday)
ThisMonth = Month(LDate)
FirstMonth = Month(FirstDate)
RemainderOfPeriode = ColumnCount - j
ws3.Cells(3, 10).Value = months(FirstMonth)
If j > 10 Then
If Month(LDate) = Month(LDate - 1) Then
ws3.Range(Cells(3, j - 1), Cells(3, j)).Merge
ws3.Cells(3, j).Borders(xlEdgeRight).LineStyle = xlContinuous
End If
If Month(LDate) <> Month(LDate - 1) Then
ws3.Cells(3, j).Value = months(ThisMonth)
End If
End If
If LWeekday = 1 Then
ws3.Cells(5, j).Value = "m"
ws3.Cells(4, j).Value = LWeek
If j = 10 Then
If RemainderOfPeriode < 7 Then
ws3.Range(Cells(4, j), Cells(4, j + RemainderOfPeriode)).Merge
Else
ws3.Range(Cells(4, j), Cells(4, j + 6)).Merge
End If
End If
If j > 10 Then
If RemainderOfPeriode < 7 Then
ws3.Range(Cells(4, j), Cells(4, j + RemainderOfPeriode)).Merge
Else
ws3.Range(Cells(4, j), Cells(4, j + 6)).Merge
End If
End If
End If
If LWeekday = 2 Then
ws3.Cells(5, j).Value = "t"
If j = 10 Then
ws3.Cells(4, j).Value = LWeek
If RemainderOfPeriode < 6 Then
ws3.Range(Cells(4, j), Cells(4, j + RemainderOfPeriode)).Merge
Else
ws3.Range(Cells(4, j), Cells(4, j + 5)).Merge
End If
End If
End If
If LWeekday = 3 Then
ws3.Cells(5, j).Value = "o"
If j = 10 Then
ws3.Cells(4, j).Value = LWeek
If RemainderOfPeriode < 5 Then
ws3.Range(Cells(4, j), Cells(4, j + RemainderOfPeriode)).Merge
Else
ws3.Range(Cells(4, j), Cells(4, j + 4)).Merge
End If
End If
End If
If LWeekday = 4 Then
ws3.Cells(5, j).Value = "t"
If j = 10 Then
ws3.Cells(4, j).Value = LWeek
If RemainderOfPeriode < 4 Then
ws3.Range(Cells(4, j), Cells(4, j + RemainderOfPeriode)).Merge
Else
ws3.Range(Cells(4, j), Cells(4, j + 3)).Merge
End If
End If
End If
If LWeekday = 5 Then
ws3.Cells(5, j).Value = "f"
If j = 10 Then
ws3.Cells(4, j).Value = LWeek
If RemainderOfPeriode < 3 Then
ws3.Range(Cells(4, j), Cells(4, j + RemainderOfPeriode)).Merge
Else
ws3.Range(Cells(4, j), Cells(4, j + 2)).Merge
End If
End If
End If
If LWeekday = 6 Then
ws3.Cells(5, j).Value = "l"
If j = 10 Then
ws3.Cells(4, j).Value = LWeek
If RemainderOfPeriode < 2 Then
ws3.Range(Cells(4, j), Cells(4, j + RemainderOfPeriode)).Merge
Else
ws3.Range(Cells(4, j), Cells(4, j + 1)).Merge
End If
End If
End If
If LWeekday = 7 Then
ws3.Cells(5, j).Value = "s"
If j = 10 Then
ws3.Cells(4, j).Value = LWeek - 1
End If
End If
LDate = DateAdd("d", 1, LDate)
Next j
Sheets("Indtastningsark").Select
ActiveSheet.Unprotect Password:="5980"
ws1.Cells(9, 26).Value = ws3.Cells(4, 3).Value
ws1.Cells(10, 26).Value = ws3.Cells(4, 5).Value
ws1.Cells(11, 26).Value = ws3.Cells(4, 6).Value
ActiveSheet.Protect Password:="5980", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True
Sheets("Vis_Oversigt").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
