PDA

View Full Version : Solved: inserting date where cursor located



av8tordude
07-17-2010, 10:38 AM
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
07-17-2010, 11:33 AM
In frmCalendar change



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


to



Public ThisButton As Date

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


and in your userforms change the textbox enter procedure to



Private Sub TextBox1_Enter()
frmCalendar.Show
TextBox1.Text = frmCalendar.ThisButton
End Sub

av8tordude
07-17-2010, 02:28 PM
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
07-17-2010, 04:15 PM
Can anyone assist?

Bob Phillips
07-18-2010, 02:42 AM
That is what I did.

av8tordude
07-18-2010, 04:20 AM
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
07-18-2010, 08:13 AM
Aah, okay.

Sheet1 code


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


Userform1 code


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


frmCalendar code


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

av8tordude
07-18-2010, 11:16 AM
Most Excellent...XLD:friends:

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
07-19-2010, 10:40 PM
Add a "Cancel" button that clears the contents of the cell.
Yes, that's why we don't use merged cells! Try center across selection instead.

av8tordude
07-28-2010, 01:19 PM
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