Календарь MsWord2013 - Автоматизировать заполнение расписания

Sub test()
 
    Const FirstWDay As Integer = vbMonday 'Первый день недели
    Const week As Integer = 18  'Количество недель
    Const Hcount As Integer = 600  'Количество часов
    Const FDate As Date = #4/4/2015#  'Начальная дата
    Const Vihodn As String = "6,7"  'Номера выходный дней через запятую
    
    Dim i As Integer, WDays As Integer, iW As Integer
    Dim t1 As Integer, t2 As Integer
    Dim curr As Date
    Dim arr()
 
    WDays = week * (7 - UBound(Split(Vihodn, ",")) - 1)
       
    t1 = Hcount Mod WDays
    t2 = WDays
 
    For i = t1 To 2 Step -1
        If (t1 / i = t1 \ i) And (t2 / i = t2 \ i) Then
            t1 = t1 / i
            t2 = t2 / i
        End If
    Next i
 
    ReDim arr(1 To Month(DateAdd("ww", week, FDate)) - Month(FDate) + 2, 1 To 32)
 
    For i = 2 To UBound(arr, 1)
        arr(i, 1) = MonthName(Month(DateAdd("m", i - 2, FDate)))
    Next i
    
    For i = 2 To 32
        arr(1, i) = i - 1
    Next i
    
    iW = 0
    For i = 1 To DateDiff("d", FDate, DateAdd("ww", week, FDate))
        curr = DateAdd("d", i - 1, FDate)
        If Not Weekday(curr, FirstWDay) Like "[" & Vihodn & "]" Then
            iW = iW + 1
            arr(Month(curr) - Month(FDate) + 2, Day(curr) + 1) = Hcount \ WDays + IIf(iW Mod t2 < t1, 1, 0)
        End If
    Next i
 
    Sheets.Add
    Range(Cells(1, 2), Cells(1, UBound(arr, 2))).ColumnWidth = 3
    
    With Range(Cells(1, 1), Cells(UBound(arr, 1), UBound(arr, 2)))
        .Value = arr
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
    End With
    With Union(Range(Cells(1, 2), Cells(1, UBound(arr, 2))), Range("A2:A" & UBound(arr, 1)))
        .Interior.Color = 65535
        .Borders(xlInsideVertical).Weight = xlMedium
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).Weight = xlMedium
        .Borders(xlInsideHorizontal).Weight = xlMedium
        .Borders(xlEdgeLeft).Weight = xlMedium
    End With
End Sub