Подправить vba код

[artbotva]

Всем доброго времени суток.
Помогите пожалуйста с кодом. У меня есть:

Option Explicit
Function DaysInMonth(D As Date) As Integer
  Dim Dt1 As Date, Dt2 As Date
    Dt1 = DateSerial(Year(D), Month(D), 1)
    Dt2 = DateSerial(Year(D), Month(D) + 1, 1)
    DaysInMonth = Dt2 - Dt1
End Function
Sub FillTable()
Dim Rng As Range
Dim i As Integer, Dt1 As Date, Days2 As Integer
 Dt1 = Cells(1, 1).Value
   Days2 = DaysInMonth(Dt1)
   For i = 1 To Days2
        Cells(5, i).Value = WeekdayName(Weekday(Dt1 - 1))
        Cells(6, i).Value = Day(Dt1)
        Dt1 = Dt1 + 1
    Next i
End Sub

Private Sub CommandButton1_Click()
Call FillTable
End Sub

Он отображает вот так:


А надо вот так:

[artbotva]

Заранее спасибо)

[Aleksandr H.]

Sub FillTable()
Dim Rng As Range, r As Byte, c As Byte
Dim i As Integer, Dt1 As Date, Days2 As Integer
 Dt1 = Cells(1, 1).Value
   Days2 = DaysInMonth(Dt1)
   For i = 1 To 7
    Cells(4, i) = WeekdayName(i)
   Next
   Range(Cells(5, 1), Cells(10, 8)).Clear
   r = 5: c = Weekday(DateSerial(Year(Dt1), Month(Dt1), 1), vbMonday)
   i = 1
   Do While i <= Days2
        Cells(r, c).Value = i
        If c Mod 7 = 0 Then
            r = r + 1
            c = 0
        End If
        c = c + 1
        i = i + 1
    Loop
End Sub

[IgorGO]

Sub FillTable()
  Dim Dt As Date, r&, c&, m&
  m = Month(Cells(1, 1)): Dt = DateSerial(Year(Cells(1, 1)), m, 1): r = 3: c = Weekday(Dt, 2)
  Do While Month(Dt) = m
    Cells(r, c) = Day(Dt):  Dt = Dt + 1:  If c = 7 Then c = 1: r = r + 1 Else c = c + 1
  Loop
End Sub