Calendar

[Exhumes]

' ===================================================
' Code by Martin Green eMail
' Visit my Office Tips web site at
' ===================================================

Private Sub Workbook_Open2()
Dim NewControl As CommandBarControl
' Assign shortcut to display calendar on SHIFT+CTRL+C
Application.OnKey "+^{C}", "Module1.OpenCalendar"
' Add item to shortcut menu on open
On Error Resume Next
Application.CommandBars("Cell").Controls("Insert Date").Delete
On Error GoTo 0
Set NewControl = Application.CommandBars("Cell").Controls.Add
With NewControl
.Caption = "Insert Date"
.OnAction = "Module1.OpenCalendar"
.BeginGroup = True
End With
End Sub

Private Sub Workbook_BeforeClose2(Cancel As Boolean)
' Delete item from shortcut menu on close
On Error Resume Next
Application.CommandBars("Cell").Controls("Insert Date").Delete
End Sub

----------------------

i usually use button to pop up calender which is attached in forms but this works whenever the mouse set in any cell how can i make it fixed on certain Cell

 

[Exhumes]

Sorry i should of post this Code :

Option Explicit

' ===================================================
' Code by Martin Green
' Visit my Office Tips web site at ' ===================================================

Private Sub cmdClose_Click()
' Close the UserForm
Unload Me
End Sub

Private Sub UserForm_Initialize()
' Check if active cell contains a date. If 'yes' show
' same date on calendar. If 'no' show today's date.
If IsDate(ActiveCell.Value) Then
Calendar1.Value = DateValue(ActiveCell.Value)
Else
Calendar1.Value = Date
End If
End Sub

Private Sub Calendar1_Click()
' Transfer date selected on calendar to active cell
' and close UserForm.
ActiveCell.Value = Calendar1.Value
Unload Me
End Sub

 

[Geoff Taylor]

If I understand you correctly, simply replace "activecell.value" with "Range("A1").value".

In place of A1 choose whatever cell address you require.