Hello NickHK,

Thank you for the modifed code it works but after the date is entered
in B8 it goes to B2 and scrolls through all the cells B8:B15. Is there
a way to add a msgbox with the option to exit sub or enter another date
in next cell?

Thank you for your help,
jfcby

NickHK wrote:
Is this what you mean ?
No need for all those shapes then.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Target, Range("B8:B15")) Is Nothing Then
Application.EnableEvents = False
Target(1).Select
Application.EnableEvents = True
Application.Run "PERSONAL.XLS!OpenCalendar"
End If

End Sub

NickHK

"jfcby" wrote in message
ups.com...
Hello,

Worksheet3 rowB cells8-15, I need each cell when clicked in to call
Macro PERSONAL.XLS!OpenCalendar (popup calendar) and select the cell
so that when the date is clicked on the calendar it will be inserted in
the click cell.

To get the each cell active I've placed a rectangle to call the
PERSONAL.XLS!OpenCalendar (popup calendar). But, with the code below
when I click in cell 8-14 it always selects cell15.

How can the code be changed so that when I click in cell 8-14 it will
be selected to insert the date from the popup calendar?

Sub CellDateActivate()
With ActiveSheet.Shapes("Rectangle 4").Select
Range("B8").Select
End With
With ActiveSheet.Shapes("Rectangle 5").Select
Range("B9").Select
End With
With ActiveSheet.Shapes("Rectangle 6").Select
Range("B10").Select
End With
With ActiveSheet.Shapes("Rectangle 7").Select
Range("B11").Select
End With
With ActiveSheet.Shapes("Rectangle 8").Select
Range("B12").Select
End With
With ActiveSheet.Shapes("Rectangle 9").Select
Range("B13").Select
End With
With ActiveSheet.Shapes("Rectangle 10").Select
Range("B14").Select
End With
With ActiveSheet.Shapes("Rectangle 11").Select
Range("B15").Select
End With
Application.Run "PERSONAL.XLS!OpenCalendar"
End Sub

Thank you for your help in advance,
jfcby