Skrive uger i stedet for måneder VBA

Hej med Jer

Jeg har forsøgt at rette i en kode, som jeg fandt på nettet - men desværre virker den ikke helt efter hensigten.
Måske er der én som kan hjælpe med at få den optimeret samt få den til at fungere.

Sub x1()
    Dim x As Integer
    ReDim Months(1 To 12)
    Dim MonthYear As String, txt As String, wm As String
    Dim InputDate As Date, MonthYearDay As Date
    Dim i As Long, intDaysInMonth As Long, j As Long
    Dim MyArray As Variant
    Dim arr As New Collection, a
   
    Months = Array("Januar", "Februar", "Marts", "April", "Maj", "Juni", "Juli", "August", "September", "Oktober", "November", "December")
   
    For Each c In Worksheets("Ark1").Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
        For x = 0 To 11
            If UCase(c.Value) = UCase(Months(x)) Then
                ReDim MyArray(0 To 31)
                j = 0
               
                InputDate = RetrieveDate(c.Value)
                MonthYear = Month(InputDate) & "/" & Year(InputDate)
                intDaysInMonth = Day(DateSerial(Year(MonthYear), Month(MonthYear) + 1, 0))
               
                For i = 1 To intDaysInMonth
                    MonthYearDay = DateSerial(Year(InputDate), Month(InputDate), i)
                    MyArray(j) = Application.WorksheetFunction.WeekNum(MonthYearDay)
                    j = j + 1
                Next i

                ReDim Preserve MyArray(0 To j - 1)
                On Error Resume Next
                For Each a In MyArray
                    arr.Add a, CStr(a)
                Next
               
                For i = 1 To arr.Count
                    If wm = "" Then
                        wm = arr(i)
                    Else
                        wm = wm & "+" & arr(i)
                    End If
                Next i
               
                If Right(wm, 1) = "+" Then
                    MsgBox "Uge " & Left(wm, Len(wm) - 1)
                Else
                    MsgBox "Uge " & wm
                End If
               
                wm = ""
            End If
        Next x
    Next c
End Sub

Function RetrieveDate(sDate As String) As String
    Dim i As Integer
    ReDim Months(1 To 12)
    ReDim StartMonths(1 To 12)
    ReDim EndMonths(1 To 12)
    Months = Array("Januar", "Februar", "Marts", "April", "Maj", "Juni", "Juli", "August", "September", "Oktober", "November", "December")
    StartMonths = Array("01-01", "01-02", "01-03", "01-04", "01-05", "01-06", "01-07", "01-08", "01-09", "01-10", "01-11", "01-12")
    For i = 0 To 11
        If UCase(sDate) = UCase(Months(i)) Then
                RetrieveDate = StartMonths(i) & "-" & Year(Date)
            Exit For
        End If
    Next
End Function

Den skriver egentlig det rigtige output på første måned, efterfølgende bliver der flere tilføjet.

Januar: Uge 1+2+3+4+5
Februar: Uge 1+2+3+4+5+6+7+8+9
osv

Jeg ville gerne have den til:
Januar: Uge 1+2+3+4+5
Februar: Uge 5+6+7+8+9
osv

PFT. :)