Solved: inserting date where cursor located

[av8tordude]

Hi all,

I've come across a situation where some of my new users do not have MS Date Picker on their computers. So I've did a seach and found a calendar that was design in a userform (non-active x control). Since their will be only one calendar in the workbook, I will need to be able to use this calendar to insert a date in wherever the cursor is located (either in a Userform textbox or in a sheet). I've uploaded an example of a workbook with 1-Calendar, 2-Userforms with textboxes and on Sheet1, right-clicking any cell will display the calendar so you can insert a date. Can someone assist?

Thanks in advance.

[Bob Phillips]

In frmCalendar change

[vba]

Dim ThisDay As Date
Dim ThisYear, ThisMth, ThisButton
Dim CreateCal As Boolean
Dim i As Integer
[/vba]

to

[vba]

Public ThisButton As Date

Dim ThisDay As Date
Dim ThisYear, ThisMth
Dim CreateCal As Boolean
Dim i As Integer
[/vba]

and in your userforms change the textbox enter procedure to

[vba]

Private Sub TextBox1_Enter()
frmCalendar.Show
TextBox1.Text = frmCalendar.ThisButton
End Sub
[/vba]

[av8tordude]

Thanks XLD...Can you or anyone else assist in getting the calendar to display the date in the textbox (whatever the date is currently entered)? Thank you.

[av8tordude]

Can anyone assist?

[Bob Phillips]

That is what I did.

[av8tordude]

Hi XLD,

What I meant was, whatever date that is currently in the textbox, when the calendar appears, it should show that date in the calendar. Currently, if the textbox has 3/28/10 entered, the calendar would display today's date when it appears.

[Bob Phillips]

Aah, okay.

Sheet1 code
[vba]

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
With frmCalendar

If Target.Value2 = "" Then
.ThisDate = Date
Else
.ThisDate = Target.Value
End If
.Show
Target.Value = .ThisDate
End With
End Sub
[/vba]

Userform1 code
[vba]

Private Sub TextBox1_Enter()
With frmCalendar

If Me.TextBox1.Text = "" Then
.ThisDate = Date
Else
.ThisDate = CDate(Me.TextBox1.Text)
End If
.Show
Me.TextBox1.Text = .ThisDate
End With
End Sub
[/vba]

frmCalendar code
[vba]

Option Explicit

Public ThisButton As Date
Public ThisDate As Date

Dim ThisDay As Date
Dim ThisYear As Long, ThisMth As Long
Dim CreateCal As Boolean
Dim i As Integer

Private Sub cmdCancel_Click()
Me.Hide
End Sub

Private Sub UserForm_Activate()
Application.EnableEvents = False
ThisMth = Format(ThisDate, "mm")
ThisYear = Format(ThisDate, "yyyy")
For i = 1 To 12
CB_Mth.AddItem Format(DateSerial(ThisYear, i, 1), "mmmm")
Next
CB_Mth.ListIndex = (ThisMth) - 1
For i = -100 To 100
If i = 1 Then CB_Yr.AddItem Format((ThisDay), "yyyy") Else CB_Yr.AddItem _
Format((DateAdd("yyyy", (i - 1), ThisDay)), "yyyy")
Next
CB_Yr.ListIndex = 101
CreateCal = True
ThisButton = ThisDate
Call Build_Calendar
Application.EnableEvents = True
CB_Mth.ListIndex = ThisMth - 1
CB_Yr.Value = ThisYear
CB_Today.Caption = "Today: " & ThisDate
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

End Sub

Private Sub B_Cancel_Click()
Me.Hide
End Sub

Private Sub CB_Today_Click()
ThisButton = Format(Date, "m/d/yy")
CB_Mth.Value = Format(Date, "mmmm")
CB_Yr.Value = Format(Date, "yyyy")
HelpLabel.Caption = ThisButton
ThisDate = HelpLabel.Caption
Me.Hide
End Sub

Private Sub SB_Month_Change()
If CB_Mth.ListIndex > 0 And CB_Mth.ListIndex < 11 Then CB_Mth.ListIndex = CB_Mth.ListIndex + SB_Month.Value
If CB_Mth.ListIndex = 0 And SB_Month.Value = 1 Or CB_Mth.ListIndex = 11 And SB_Month.Value = -1 Then CB_Mth.ListIndex = CB_Mth.ListIndex + SB_Month.Value
SB_Month.Value = 0
End Sub

Private Sub SB_Year_Change()
If CB_Yr.ListIndex > 0 And CB_Yr.ListIndex < 199 Then CB_Yr.ListIndex = CB_Yr.ListIndex + SB_Year.Value
If CB_Yr.ListIndex = 0 And SB_Year.Value = 1 Or CB_Yr.ListIndex = 199 And SB_Year.Value = -1 Then CB_Yr.ListIndex = CB_Yr.ListIndex + SB_Year.Value
SB_Year.Value = 0
End Sub

Private Sub CB_Mth_Change()
Build_Calendar
End Sub

Private Sub CB_Yr_Change()
Build_Calendar
End Sub

Private Sub Build_Calendar()
If CreateCal = True Then
frmCalendar.Caption = " " & CB_Mth.Value & " " & CB_Yr.Value
CommandButton1.SetFocus
For i = 1 To 42
If i < Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy")
ElseIf i >= Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value)) Then
Controls("D" & (i)).Caption = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) _
& "/1/" & (CB_Yr.Value))), ((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "d")
Controls("D" & (i)).ControlTipText = Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy")
End If
If Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "mmmm") = ((CB_Mth.Value)) Then
If Controls("D" & (i)).BackColor <> &H80000016 Then Controls("D" & (i)).BackColor = &H80000018 '&H80000010
Controls("D" & (i)).Font.Bold = True
If Format(DateAdd("d", (i - Weekday((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), _
((CB_Mth.Value) & "/1/" & (CB_Yr.Value))), "m/d/yy") = Format(ThisButton, "m/d/yy") Then Controls("D" & (i)).SetFocus
Else
If Controls("D" & (i)).BackColor <> &H80000016 Then Controls("D" & (i)).BackColor = &H8000000F
Controls("D" & (i)).Font.Bold = False
End If
Next
End If
End Sub

Private Sub B_Insert_Date_Click()
Dim Question
If UserForm1.Visible = True And HelpLabel.Caption <> "Select Desired Date" Then
ThisDate = HelpLabel.Caption
ElseIf HelpLabel.Caption <> "Select Desired Date" Then
ThisDate = HelpLabel.Caption
End If
If HelpLabel.Caption = "Select Desired Date" Then Question = MsgBox("You have not selected a date to insert. Would you like to return to the calendar to select a date?", vbQuestion + vbYesNo, "No date selected")
If Question = vbYes Then Exit Sub
Me.Hide
End Sub

Private Sub ChkDate()
If Format(ThisButton, "m") - 1 <> CB_Mth.ListIndex Then CB_Mth.ListIndex = Format(ThisButton, "m") - 1
End Sub

Private Sub D1_Click()
ThisButton = D1.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D2_Click()
ThisButton = D2.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D3_Click()
ThisButton = D3.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D4_Click()
ThisButton = D4.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D5_Click()
ThisButton = D5.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D6_Click()
ThisButton = D6.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D7_Click()
ThisButton = D7.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D8_Click()
ThisButton = D8.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D9_Click()
ThisButton = D9.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D10_Click()
ThisButton = D10.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D11_Click()
ThisButton = D11.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D12_Click()
ThisButton = D12.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D13_Click()
ThisButton = D13.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D14_Click()
ThisButton = D14.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D15_Click()
ThisButton = D15.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D16_Click()
ThisButton = D16.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D17_Click()
ThisButton = D17.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D18_Click()
ThisButton = D18.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D19_Click()
ThisButton = D19.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D20_Click()
ThisButton = D20.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D21_Click()
ThisButton = D21.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D22_Click()
ThisButton = D22.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D23_Click()
ThisButton = D23.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D24_Click()
ThisButton = D24.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D25_Click()
ThisButton = D25.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D26_Click()
ThisButton = D26.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D27_Click()
ThisButton = D27.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D28_Click()
ThisButton = D28.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D29_Click()
ThisButton = D29.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D30_Click()
ThisButton = D30.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D31_Click()
ThisButton = D31.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D32_Click()
ThisButton = D32.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D33_Click()
ThisButton = D33.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D34_Click()
ThisButton = D34.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D35_Click()
ThisButton = D35.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D36_Click()
ThisButton = D36.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D37_Click()
ThisButton = D37.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D38_Click()
ThisButton = D38.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D39_Click()
ThisButton = D39.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D40_Click()
ThisButton = D40.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D41_Click()
ThisButton = D41.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub
Private Sub D42_Click()
ThisButton = D42.ControlTipText
ChkDate
ThisDate = ThisButton
Me.Hide
End Sub

Sub Record(d As Long)
Dim cD As Long, r As Range

Set r = Sheets("Logbook").Range("a9:a10010")
If Application.WorksheetFunction.CountA(r) = 0 Then
MsgBox "No Flight Data Found!", vbExclamation, "Logbook"
Exit Sub
End If
cD = Evaluate("=match(min(abs('Logbook'!a9:a10010-" & d & "))," & _
"abs('Logbook'!a9:a10010-" & d & "),0)")

Sheets("Logbook").Range("a8").Offset(cD).Activate
End Sub
[/vba]

[av8tordude]

Most Excellent...XLD

One last request ...when I call the calendar and decide not to enter a date and close the calendar, a date is inserted when I do not want to enter a date. Also, I get an error when i try to enter a date into a cell that is merged. How can I correct this..Thanks again

[geekgirlau]

1. Add a "Cancel" button that clears the contents of the cell.
2. Yes, that's why we don't use merged cells! Try center across selection instead.

[av8tordude]

Found a solution to my problem with inserting a date into merged cells.

If Not (Nothing Is Application.Intersect(Target, Range("D18:D23, E13, G21:G23"))) Then
    Cancel = True
    With frmCalendar
    If Target.MergeCells = True Then
        rng = Left(Target.Address, Application.WorksheetFunction.Find(":", Target.Address) - 1)
        If Len(Range(rng).Value) = 0 Then
            .ThisDate = Date
        Else
            .ThisDate = Target.Select
            End If
        End If
        .Show
        Target.Value = .ThisDate
    End With
End If