Sub NewDayNrInYear(InDate As String, ReturnDay As String, Week As String, WeekDay As String, Month As String)
Dim fLeapYear As Boolean
Dim i As Long
Dim lDay As Long
Dim lDayOfYear As Long
Dim lMonth As Long
Dim lTmp As Long
Dim lTmpDay1 As Long
Dim lWeek As Long
Dim lWeekDay As Long
Dim lWeekDay1 As Long
Dim lYear As Long
Dim aDaysInMonth As Variant

If Len(InDate) = 8 Then
'''YYYYMMDD
lYear = Left$(InDate, 4)
lMonth = Mid$(InDate, 5, 2)
lDay = Right$(InDate, 2)
ElseIf Len(InDate) = 6 Then
'''YYMMDD (YY>90 antag att vi är på 1900-talet
lYear = Left$(InDate, 2)
If lYear > 90 Then lYear = lYear + 1900 Else lYear = lYear + 2000
lMonth = Mid$(InDate, 3, 2)
lDay = Right$(InDate, 2)
Else
MsgBox "Felaktigt datum format": Exit Sub
End If

If lMonth > 12 Then MsgBox "Felaktig månad": Exit Sub

fLeapYear = (lYear Mod 4 = 0)
If (lYear Mod 100 = 0) Then fLeapYear = (lYear Mod 400 = 0)

aDaysInMonth = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
If fLeapYear Then aDaysInMonth(2) = 29
If lDay > aDaysInMonth(lMonth) Then MsgBox "Invalid day": Exit Sub

lTmp = (lYear - 1900) * 365 + (lYear - 1900) \ 4 - ((lYear - 1900) \ 400) * 3 + CInt(fLeapYear)
lTmpDay1 = lTmp + 1
For i = 1 To lMonth - 1
lDayOfYear = lDayOfYear + aDaysInMonth(i)
Next
lDayOfYear = lDayOfYear + lDay

ReturnDay = Right$("000" & lDayOfYear, 3)
lWeekDay = ((lTmp + lDayOfYear + 6) Mod 7) + 1
lWeekDay1 = ((lTmp + 6) Mod 7) + 1
WeekDay = Choose(lWeekDay, "Måndag", "Tisdag", "Onsdag", "Torsdag", _
"Fredag", "Lördag", "Söndag")
Month = Choose(lMonth, "Januari", "Februari", "Mars", "April", "Maj", _
"Juni", "Juli", "Augusti", "September", "Oktober", "November", "December")

lWeek = (lDayOfYear + lWeekDay1 - lWeekDay + 1) \ 7 + CInt(lWeekDay1 > 3) + 1

If lWeek = 0 Then
'''Kolla veckor föregående år
lYear = lYear - 1
fLeapYear = (lYear Mod 4 = 0)
If (lYear Mod 100 = 0) Then fLeapYear = (lYear Mod 400 = 0)
lTmp = (lYear - 1900) * 365 + (lYear - 1900) \ 4 - ((lYear - 1900) \ 400) * 3
lTmpDay1 = lTmp + 1 + CInt(fLeapYear)
lTmp = lTmpDay1 Mod 7
If lTmp > 4 Or lTmp = 0 Then
'''Aldrig 53 veckor 2 år i följd
lWeek = 52
Else
lWeek = 53
End If
ElseIf lWeek = 53 Then
lYear = lYear + 1
fLeapYear = (lYear Mod 4 = 0)
If (lYear Mod 100 = 0) Then fLeapYear = (lYear Mod 400 = 0)
lTmp = (lYear - 1900) * 365 + (lYear - 1900) \ 4 - ((lYear - 1900) \ 400) * 3
lTmpDay1 = lTmp + 1 + CInt(fLeapYear)
lTmp = lTmpDay1 Mod 7
If Not (lTmp > 4 Or lTmp = 0) Then lWeek = 1
End If

Week = Right$("00" & lWeek, 2)
End Sub