Excel Macros : Excel Date Picker

This is first post of the year 2010, I wish all my blog readers a very happy and prospurous year. Today I am sharing Excel Date Picker Utility with you. Following picture will demonstrate some to the capabilities of this utility.





This utility will help you with following

1. In case you select a cell with date, or select any cell around the cell with a date. It will show floating button on the left side of the cell. If you click on the floating button it will show popup calender.
2. In case the cell already has a date , the calendar will show same date by default, else it will show current date.
3. You can jump the months by click on the month value on the popup calendar.
4. Click on the year will show spin buttons next to it and you can change year easily with spin buttons.
5. When you click on the date in popup calander, it will insert date clicked to the selected cell
6. You can also use Ctrl+Shift+d to show popup calender on your screen.
7. In case you get pop up calander and you do not want to click any date, just press Esc to close the pou up calendar.

This utility could be usefull in following ways

1. Many people end up entering date in text format as some time it is difficult to enter the date in correct computer readable format. With the popup calander, system takes care of the proper date entry.
2. Some times you have to get data from other users and you want them to enter dates in proper format so that rest of the worksheet can use those date inputs. With this utility you can be assured about this issue.

You may figure out many more usage based on your needs. The VBA code for Excel date Picker is available in the downloadable file. You can further modify the code as per your needs.

Now how to use this Excel Date Picker Utility

1. Download file and save it as Excel Addin on your machine.
2. You will need to copy this code to worksheet module of your workbook.

You will need to add this code to show the Floating button. This code will creat the button in case it does not exist on it. All other features like cell menu on right click and popup calender on Ctrl+Shift+d will be available in case you do not add this code by saving download able file as Excel Addin on your machine. I am suggesting this because I still need to learn how to trigger worksheet selection change event with a vba code in addin.

Private Sub FloatingButton_Click() Calander.Show End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Application.CutCopyMode = 1 Then Exit Sub ElseIf Target.Cells.Count > 1 Then Exit Sub Else Set r = Target Hasdate = 0 For x = -1 To 1 For y = -1 To 1 On Error GoTo Etrap1 If IsDate(r.Offset(x, y)) Then Hasdate = 1 Exit For End If Rsume1: Next y If Hasdate = 1 Then Exit For Rsume: Next x If Hasdate = 1 Then FloatingButton.Left = r.Offset(0, 1).Left FloatingButton.Top = r.Top FloatingButton.Visible = True Else If Not FloatingButton.Visible = False Then FloatingButton.Visible = False End If End If Exit Sub End If Etrap1: If r.Row = 1 Then Resume Rsume ElseIf r.Column = 1 Then Resume Rsume1 End If End Sub Private Sub Worksheet_Activate() Dim s As String On Error Resume Next s = ActiveSheet.FloatingButton.Caption If Err.Number <> 0 Then ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False _ , DisplayAsIcon:=False, Left:=147.75, Top:=34.5, Width:=15.75, Height:= _ 15.75).Select Selection.Name = "FloatingButton" ActiveSheet.OLEObjects("FloatingButton").Object.Caption = "" ActiveSheet.OLEObjects("FloatingButton").Object.BackColor = &H80000005 Range("A1").Select FloatingButton.Visible = False End If On Error GoTo 0 End Sub

However this will not work on the files you send to other users. In that case you need to builtin the entire utility into the file you are sending out.

Following steps will help you to do this.

1. You will need to copy this code to workbook module of your workbook

Private Sub Workbook_Open() Dim NewControl As CommandBarControl Application.OnKey "+^{D}", "Module1.ShowCalander" On Error Resume Next Application.CommandBars("Cell").Controls("Show Date Picker").Delete On Error GoTo 0 Set NewControl = Application.CommandBars("Cell").Controls.Add With NewControl .Caption = "Show Date Picker" .OnAction = "Module1.ShowCalander" .BeginGroup = True End With End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.CommandBars("Cell").Controls("Show Date Picker").Delete End Sub

2. You will need to copy this code to regular VBA module - Module1 of your workbook

Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Declare Function ReleaseCapture Lib "user32" () As Long Private Const GWL_STYLE As Long = (-16) Private wHandle As Long Sub ShowCalander() Calander.Show End Sub

3. Move form named calander from the downloadable file to your file.

With these steps you can send the file to other users and it will work in similar way as it works on your machine.

In addition you can force users to enable macros while using your file

Download file with Excel Date Picker Utility