Using VBA to automatically insert a popup calendar and link it to a cell

[magicweasel]

I've been attempting with no success to use VBA to place a pop up calendar sized and linked to a cell. The goal is to use this to fill a column with about 20 cells and then eventually add a feature to insert a new row with all of the formulas and feature I want.

I can get my code to place one calendar before it errors out. However the pop up calendar it places does not function, and a ghost calendar of sorts appears in the top left of the spread sheet that functions normally.

My Code:

Sub PlaceCal()
Dim ToRow As Long
Dim LastRow As Long
Dim MyLeft As Double
Dim MyTop As Double
Dim MyHeight As Double
Dim MyWidth As Double
Dim Cl As Range
'--------------------------
LastRow = Range("F28").Row
For ToRow = 18 To LastRow
'-
MyLeft = Cells(ToRow, "F").Left
MyTop = Cells(ToRow, "F").Top
MyHeight = Cells(ToRow, "F").Height
MyWidth = Cells(ToRow, "F").Width
'-
ActiveSheet.OLEObjects.Add(ClassType:="MSComCtl2.DTPicker.2", Link:=False, _
DisplayAsIcon:=False, Left:=MyLeft, Top:=MyTop, Width:=MyWidth, Height:= _
MyHeight).Select
With Selection
.Caption = ""
.Value = xlOff
.LinkedCell = "F" & ToRow
.Display3DShading = False
'------------------------------------------------------
'- format

'-------------------------------------------------------------
End With
Cells(ToRow, "F").Font.Color = RGB(255, 255, 255)
Next
End Sub

And screen shots of my problems:

This is what the program does:

http://imgur.com/anwjL17,RUJPWdZ#1

This is the error I receives after it places the first calendar

http://imgur.com/anwjL17,RUJPWdZ#0