Related
Dears,
I want to make a simple userform to record some serial numbers into excel, it contains a textbox_serialNo., a command button “enter” and another command button “cancel”.
I made a validation control in that serialNo textbox so that only number can be entered. However, when I run the program and input some numbers into the textbox, both command buttons (the "enter" button named as label_enter,the "cancel" button named as label_cancel) have no reactions (e.g. the "cancel" button doesn't unload the form when press) , how should I correct the program? Below are the relevant codes, Thanks.
Private Sub TextBox_SerialNo_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsNumeric(TextBox_SerialNo.Value) Then
TextBox_SerialNo.BackColor = rgbYellow
End If
Cancel = True
End Sub
Private Sub TextBox_SerialNo_AfterUpdate()
If TextBox_SerialNo.Value <> "" Then
TextBox_SerialNo.BackColor = rgbWhite
End If
End Sub
Private sub label_enter_click()
sheet1.Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value + 1
ActiveCell.Offset(0, 1) = TextBox_SerialNo.Value
TextBox_SerialNo.Value = ""
End Sub
Private Sub Label_Cancel_Click()
Unload Me
End Sub
Sorry to be posting as an answer, not enough rep.
Shouldn't Cancel=True be inside the if statement? You are locking it up regardless of entry being numeric or not as is.
Edit:
Actually upon further testing still not working proper. However, change event works better and you can get instant feedback for any non numerics.
Updated code would look like this, control names differ. I am used to working with .Text, same thing as .Value. Also, since I am not sure what you would do with an empty string, assumed it to be yellow background as well.
One concern would be, can you allow comma or period in there? Depending on locale settings, a decimal would also be considered a numeric.
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdEnter_Click()
If TextBox1.BackColor = rgbYellow Then Exit Sub
test4.Range("A1").Value = TextBox1.Text
End Sub
Private Sub TextBox1_Change()
If Not IsNumeric(TextBox1.Text) Or TextBox1.Text = "" Then
TextBox1.BackColor = rgbYellow
Else
If TextBox1.Text <> "" Then
TextBox1.BackColor = rgbWhite
End If
End If
End Sub
Edit 2: I use this piece of code to check for only numbers (assuming number Ascii codes are standard). Maybe it can help.
Public Function isnumber(ByVal strValue As Variant) As Boolean
On Error Resume Next
Dim i As Long
isnumber = True
If Not strValue = "" Then
For i = 1 To Len(CStr(strValue))
If Asc(Mid(strValue, i, 1)) > 57 Or Asc(Mid(strValue, i, 1)) < 48 Then
isnumber = False
Exit For
End If
Next i
Else
isnumber = False
End If
On Error GoTo 0
Err.Clear
End Function
Edit 3: I have revised the TextBox1_Change event code so all invalid characters are stripped right away. However, in this state if you copy paste a serial no with a non-allowed char, it will strip them leaving only the numbers. Not sure if it is acceptable.
Private Sub TextBox1_Change()
If Not isnumber(TextBox1.Text) Or TextBox1.Text = "" Then
TextBox1.BackColor = rgbYellow
Dim i As Long
Dim strValue As String
strValue = ""
If Not TextBox1.Text = "" Then
For i = 1 To Len(CStr(TextBox1.Text))
If Not (Asc(Mid(TextBox1.Text, i, 1)) > 57 Or Asc(Mid(TextBox1.Text, i, 1)) < 48) Then
strValue = strValue & Mid(TextBox1.Text, i, 1)
End If
Next i
End If
TextBox1.Text = strValue
Else
If TextBox1.Text <> "" Then
TextBox1.BackColor = rgbWhite
End If
End If
End Sub
I am new to vba and I want to learn. Please help me with the following:
I have this application(see the picture) which I use to enter data in a worksheet (it is more easy to use compared to completing manually). It is basically an inventory management system. When I add a product in there I can choose between sale or purchase.
The next thing I would like to implement is to autofill the form whenever I want to add a sale (considering it was added as a purchase in the first place), based on a serial code for example. This would be very useful because I wont have to complete all the text boxes again when I enter a sale in the database
Do you have any ideas about how I could do this?
Kind regard,
Traian.
So, basically I shouldn't help since you have not done your research, but I did find it interesting to see if I could create such a function.
You wont be able to simply paste the code but it does work exactly as a autofill.
This is the "data" source I used for the autofill, it's looking for the left value and will autocomplete that textbox, as well as a secondary textbox with the value from column C. This would work with n numbers of autofills.
I only used 2 different fields to test this idea, disregard the labels. This is how it looked without typing anything.
As soon as you start to type, the "autofill" appears.
If you were to "hover" over the autofill, it will turn a different color, as well as all the input sheets, the input sheet also now includes the autofilled answers. if you were to "unhover"(hover over anything except the autofill) it will revert back to the second picture.
If I were to write this code again for a real project, I would change a couple of thing.
There might be leftover code from my testing, I would remove this.
I would use global variables so to avoid declaring variables more than one time.
I would name the textboxes and label in a better way.
I would complicate the textboxes with labels as to get the text to align in center.
The order of the code might not be the best for you to understand.
etc.
Here is the code:
Private Sub Autofill_Click()
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox2 = Start.Offset(BestOption, 1)
TextBox1 = Start.Offset(BestOption, 0)
Autofill.Visible = False
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Private Sub TextBox1_Change()
Dim Start As Range
Dim ValueRange As Range
Dim MatchCounter As Integer
Set Start = Sheets("sheet1").Range("B7")
Set ValueRange = Sheets("sheet1").Range("B8:B13")
If TextBox1 = "" Then
Autofill.Visible = False
Else
'Call FindClosestMatch(TextBox1)
Autofill.Visible = True
Autofill = Start.Offset(FindClosestMatch(TextBox1) + 1, 0)
End If
End Sub
Function FindClosestMatch(Entry As String) As Integer
Dim BestOption As Integer
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
Dim MyArray(6) As String
Dim i As Integer
Dim j As Integer
Dim iChar As String
Dim EntryChar As String
For i = 0 To 5
MyArray(i) = Start.Offset(i + 1, 0)
Next i
For j = 1 To Len(Entry)
EntryChar = Mid(Entry, j, 1)
For i = 0 To 5
If EntryChar = "" Then
Exit For
End If
iChar = Mid(MyArray(i), j, 1)
If iChar = EntryChar Then
BestOption = i
Else
MyArray(i) = "................."
End If
Next i
Next j
FindClosestMatch = BestOption
End Function
'hover
Private Sub Autofill_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Autofill.BackColor = &H80000002
TextBox3.BackColor = &H80000002
TextBox4.BackColor = &H80000002
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox3.Visible = True
TextBox4.Visible = True
TextBox4 = Start.Offset(BestOption, 1)
TextBox3 = Start.Offset(BestOption, 0)
End Sub
Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub UserForm_Click()
Call test
Autofill.Visible = False
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Sub test()
Autofill.BackColor = &H80000000
TextBox1.BackColor = &H80000005
TextBox2.BackColor = &H80000005
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Problem to think about:
The autofill always give the best answer, even if no good answer exist. In those cases, the best answer is the first answer in the data structure.
It is case sensitive.
One charachter wrong and you wont find your answer.
Notes:
I used 4 textboxes, number 1 and 2 are sitting on top of each other, and number 2 and 4 are on top of each other. This was done to not lose the already typed input if you accidently hovered over the autofill.
I have Userform using Textbox to input date.
I'd like to show suggestion text before input like __ /__/____ (same format dd/mm/yyyy)
When enter this Textbox, cursor always in beginning. When I typing, each _ symbol will be replaced by number, and skip / symbol.
For example: I just type 05041991, in Textbox will show 05/04/1991.
Please help me about this code.
You could do something like shown below. This code is just an example (probably not perfect).
Image 1: Note that only number keys and backspace were pressed.
Put the following code into a class module and name it MaskedTextBox
Option Explicit
Public WithEvents mTextBox As MSForms.TextBox
Private mMask As String
Private mMaskPlaceholder As String
Private mMaskSeparator As String
Public Enum AllowedKeysEnum
NumberKeys = 1 '2^0
CharacterKeys = 2 '2^1
'for more options next values need to be 2^2, 2^3, 2^4, …
End Enum
Private mAllowedKeys As AllowedKeysEnum
Public Sub SetMask(ByVal Mask As String, ByVal MaskPlaceholder As String, ByVal MaskSeparator As String, Optional ByVal AllowedKeys As AllowedKeysEnum = NumberKeys)
mMask = Mask
mMaskPlaceholder = MaskPlaceholder
mMaskSeparator = MaskSeparator
mAllowedKeys = AllowedKeys
mTextBox.Text = mMask
FixSelection
End Sub
' move selection so separators get not replaced
Private Sub FixSelection()
With mTextBox
Dim Sel As Long
Sel = InStr(1, .Text, mMaskPlaceholder) - 1
If Sel >= 0 Then
.SelStart = Sel
.SelLength = 1
End If
End With
End Sub
Private Sub mTextBox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim tb As MSForms.TextBox
Set tb = Me.mTextBox
'allow paste
If Shift = 2 And KeyCode = vbKeyV Then
On Error Resume Next
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
DataObj.GetFromClipboard
Dim PasteData As String
PasteData = DataObj.GetText(1)
On Error GoTo 0
If PasteData <> vbNullString Then
Dim LikeMask As String
LikeMask = Replace$(mMask, mMaskPlaceholder, "?")
If PasteData Like LikeMask Then
mTextBox = PasteData
End If
End If
End If
Select Case KeyCode
Case vbKey0 To vbKey9, vbKeyNumpad0 To vbKeyNumpad9
'allow number keys
If Not (mAllowedKeys And NumberKeys) = NumberKeys Then
KeyCode = 0
ElseIf Len(tb.Text) >= Len(mMask) And InStr(1, tb.Text, mMaskPlaceholder) = 0 Then
KeyCode = 0
End If
Case vbKeyA To vbKeyZ
'allow character keys
If Not (mAllowedKeys And CharacterKeys) = CharacterKeys Then
KeyCode = 0
ElseIf Len(tb.Text) >= Len(mMask) And InStr(1, tb.Text, mMaskPlaceholder) = 0 Then
KeyCode = 0
End If
Case vbKeyBack
'allow backspace key
KeyCode = 0
If tb.SelStart > 0 Then 'only if not first character
If Mid$(tb.Text, tb.SelStart, 1) = mMaskSeparator Then
'jump over separators
tb.SelStart = tb.SelStart - 1
End If
'remove character left of selection and fill in mask
If tb.SelLength <= 1 Then
tb.Text = Left$(tb.Text, tb.SelStart - 1) & Mid$(mMask, tb.SelStart, 1) & Right$(tb.Text, Len(tb.Text) - tb.SelStart)
End If
End If
'if whole value is selected replace with mask
If tb.SelLength = Len(mMask) Then tb.Text = mMask
Case vbKeyReturn, vbKeyTab, vbKeyEscape
'allow these keys
Case Else
'disallow any other key
KeyCode = 0
End Select
FixSelection
End Sub
Private Sub mTextBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
FixSelection
End Sub
Put the following code into your userform
Option Explicit
Private MaskedTextBoxes As Collection
Private Sub UserForm_Initialize()
Set MaskedTextBoxes = New Collection
Dim MaskedTextBox As MaskedTextBox
'init TextBox1 as date textbox
Set MaskedTextBox = New MaskedTextBox
Set MaskedTextBox.mTextBox = Me.TextBox1
MaskedTextBox.SetMask Mask:="__/__/____", MaskPlaceholder:="_", MaskSeparator:="/"
MaskedTextBoxes.Add MaskedTextBox
'init TextBox2 as barcode textbox
Set MaskedTextBox = New MaskedTextBox
Set MaskedTextBox.mTextBox = Me.TextBox2
MaskedTextBox.SetMask Mask:="____-____-____", MaskPlaceholder:="_", MaskSeparator:="-", AllowedKeys:=CharacterKeys + NumberKeys
MaskedTextBoxes.Add MaskedTextBox
End Sub
I'm trying to avoid Event loops by disabling Events at crucial points. However, it doesn't always work. For instance, this code for a Combo box:
Private Sub TempComboS_Change()
Dim e
e = Application.EnableEvents
Application.EnableEvents = False
'
Application.EnableEvents = e
End Sub
The blank line is where the useful code goes; as it stands it obviously doesn't do anything. However, when I run it this way (with the blank line), it reaches "End Sub", then it goes back to the beginning and runs again. (This would make the useful code run twice).
Why is this happening?
EDIT: To clarify for the folks who've been helping me.
I have a macro that opens the dropdown list of the Combo box, activates it, then ends. It works properly. When I select an item from the open list, the Change event runs. This is the current version of the change event:
Private Sub TempComboS_Change()
End Sub
I put a breakpoint on the Private Sub line. It shows that this Change event runs, then runs again. I suspect that it has been doing this all along, and I noticed it now because I need to add code here.
I have no class modules or userforms. The controls are on a worksheet.
I'm going to try the "Run Once" suggestion, and I'll let you know if it works.
I tried the "Run Once" code you suggested. It sort of works, but I seem to have a bigger issue. When I select a drop-down list from a data-validated cell, the TempComboS_Change event triggers -- but not only didn't I touch this combo box, the cell isn't the LinkedCell for the combo box. In other words, it seems to be triggering by actions unconnected to the combo box!
Got to find out about that Call Stack thing...
Here is a bit of code to help investigate "sequence of events" issues
In a Standard Module
Public Enum eNewLine
No
Before
After
Both
End Enum
Public Function timeStamp(Optional d As Double = 0, Optional newLine As eNewLine = No, Optional Indent As Long = 0, _
Optional Caller As String, Optional Context As String, Optional message As String) As String
Dim errorMessage As String
If Err.number <> 0 Then
errorMessage = "ERROR: " & Err.number & ": " & Err.Description
Err.Clear
End If
If d = 0 Then d = Time
With Application.WorksheetFunction
timeStamp = .Text(Hour(d), "00") & ":" & .Text(Minute(d), "00") & ":" & .Text(Second(d), "00") & ":" & .rept(Chr(9), Indent)
End With
If Len(Caller) <> 0 Then timeStamp = timeStamp & Chr(9) & Caller
If Len(Context) <> 0 Then timeStamp = timeStamp & ": " & Chr(9) & Context
If Len(message) <> 0 Then timeStamp = timeStamp & ": " & Chr(9) & message
Select Case newLine
Case Before
timeStamp = Chr(10) & timeStamp
Case After
timeStamp = timeStamp & Chr(10)
Case Both
timeStamp = Chr(10) & timeStamp & Chr(10)
Case Else
End Select
If Len(errorMessage) <> 0 Then
timeStamp = timeStamp & Chr(9) & errorMessage
End If
End Function
At the top of each Module
'Module level Trace Hearder
Const debugEvents as Boolean = True
Const cModuleName As String = "myModuleName"
Const cModuleIndent As Long = 1
You can assign a module level indent for each module to organise the hierarchy an make it easy to understand.
In each Sub or Function (or property if you need)...
sub mySubName()
Const cMyName As String = "mySubName"
If debugEvents Then Debug.Print timeStamp(NewLine:=Before,Indent:=cModuleIndent, Caller:=cModuleName, Context:=cMyName, Message:="Start")
'Do stuff
If debugEvents Then Debug.Print timeStamp(NewLine:=After,Indent:=cModuleIndent, Caller:=cModuleName, Context:=cMyName, Message:="End")
End Sub
...Or you can use Me.Name for the Context if its a form or a sheet etc. and you can put whatever message or variable values you like in the Message.
You can also use a Timer (eg MicroTimer) and put the result in the Message section.
Here is an example output:
15:54:07: Roll-Up Select: Worksheet_Activate: Start: 3.24591834214516E-03
15:54:07: cDataViewSheet: Class_Initialize: Start
15:54:07: cRevealTarget: Class_Initialize: START
15:54:07: cRevealTarget: Class_Initialize: END
15:54:09: cDataViewSheet: startTimer: : START
15:54:09: cDataViewSheet: startTimer: init Timer
15:54:09: cOnTime: Class_Initialize
15:54:09: cOnTime: Let PulseTime: Inheret PulseTime from host sheet
15:54:09: cDataViewSheet: startTimer: : END
15:54:09: Roll-Up Select: Worksheet_Activate: END: 1.38736216780671
Private Sub cmbOrder_Change()
If cmbOrder = "" Then Exit Sub
Dim arr As Variant, maxorder As Integer
arr = Range("rngOrder")
maxorder = WorksheetFunction.Max(arr)
Dim errmsg As String, err As Boolean
err = False
errmsg = "This value must be a whole number between 1 and " & maxorder + 1
Dim v As Variant
v = cmbOrder.Value
If IsNumeric(v) = False Or (IsNumeric(v) = True And (v > maxorder + 1) Or v < 1)
Then
MsgBox errmsg
cmbOrder = ""
err = False
Else
txtOrder.Value = cmbOrder.Value
End If
End Sub
A bit late to the party but the problem of code repetition can be shown here in similar circumstances. Remove the first line of code and any error messages are dished out twice. This is because of the line that clears the ComboBox that is regarded as a change and picks up another error as null input is an error! May help someone with similar issue.
The Combobox_Change() will fire whenever there is a change in the combobox. For example
Option Explicit
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub CommandButton1_Click()
'~~> If something is selected in the combo then
'~~> this line will cause ComboBox1_Change to fire
ComboBox1.Clear
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
End Sub
So if you load the userform and select an item ComboBox1_Change will fire. You then use the commanbutton to clear the combo the ComboBox1_Change will again fire.
There is one more scenario when the change will again fire. When you change the combobox from the ComboBox1_Change event itself. Here is an example. And I believe this is what is happening in your case.
Scenario 1
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
ComboBox1.Clear
End Sub
Scenario 2
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
ComboBox1.AddItem "Bah Blah Blah"
End Sub
Private Sub ComboBox1_Change()
MsgBox "A"
ComboBox1.ListIndex = 1
End Sub
In the first scenario you can getaway with
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
End Sub
Private Sub ComboBox1_Change()
If ComboBox1 <> "" Then
MsgBox "A"
End If
End Sub
In the 2nd Scenario, you can use something like this
Dim boolRunOnce As Boolean
Private Sub UserForm_Initialize()
ComboBox1.AddItem "Bah Blah"
ComboBox1.AddItem "Bah Blah Blah"
End Sub
Private Sub ComboBox1_Change()
If boolRunOnce = False Then
MsgBox "A"
boolRunOnce = True
ComboBox1.ListIndex = 1
Else
boolRunOnce = False
End If
End Sub
I'm looking for a way to automatically format the date in a VBA text box to a MM/DD/YYYY format, and I want it to format as the user is typing it in. For instance, once the user types in the second number, the program will automatically type in a "/". Now, I got this working (as well as the second dash) with the following code:
Private Sub txtBoxBDayHim_Change()
If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
End Sub
Now, this works great when typing. However, when trying to delete, it still enters in the dashes, so its impossible for the user to delete past one of the dashes (deleting a dash results in a length of 2 or 5, and the sub is then run again, adding in another dash). Any suggestions on a better way to do this?
I never suggest using Textboxes or Inputboxes to accept dates. So many things can go wrong. I cannot even suggest using the Calendar Control or the Date Picker as for that you need to register the mscal.ocx or mscomct2.ocx and that is very painful as they are not freely distributable files.
Here is what I recommend. You can use this custom made calendar to accept dates from the user
PROS:
You don't have to worry about user inputting wrong info
You don't have to worry user pasting in the textbox
You don't have to worry about writing any major code
Attractive GUI
Can be easily incorporated in your application
Doesn't use any controls for which you need to reference any libraries like mscal.ocx or mscomct2.ocx
CONS:
Ummm...Ummm... Can't think of any...
HOW TO USE IT (File missing from my dropbox. Please refer to the bottom of the post for an upgraded version of the calendar)
Download the Userform1.frm and Userform1.frx from here.
In your VBA, simply import Userform1.frm as shown in the image below.
Importing the form
RUNNING IT
You can call it in any procedure. For example
Sub Sample()
UserForm1.Show
End Sub
SCREEN SHOTS IN ACTION
NOTE: You may also want to see Taking Calendar to new level
This is the same concept as Siddharth Rout's answer. But I wanted a date picker which could be fully customized so that the look and feel could be tailored to whatever project it's being used in.
You can click this link to download the custom date picker I came up with. Below are some screenshots of the form in action.
To use the date picker, simply import the CalendarForm.frm file into your VBA project. Each of the calendars above can be obtained with one single function call. The result just depends on the arguments you use (all of which are optional), so you can customize it as much or as little as you want.
For example, the most basic calendar on the left can be obtained by the following line of code:
MyDateVariable = CalendarForm.GetDate
That's all there is to it. From there, you just include whichever arguments you want to get the calendar you want. The function call below will generate the green calendar on the right:
MyDateVariable = CalendarForm.GetDate( _
SelectedDate:=Date, _
DateFontSize:=11, _
TodayButton:=True, _
BackgroundColor:=RGB(242, 248, 238), _
HeaderColor:=RGB(84, 130, 53), _
HeaderFontColor:=RGB(255, 255, 255), _
SubHeaderColor:=RGB(226, 239, 218), _
SubHeaderFontColor:=RGB(55, 86, 35), _
DateColor:=RGB(242, 248, 238), _
DateFontColor:=RGB(55, 86, 35), _
SaturdayFontColor:=RGB(55, 86, 35), _
SundayFontColor:=RGB(55, 86, 35), _
TrailingMonthFontColor:=RGB(106, 163, 67), _
DateHoverColor:=RGB(198, 224, 180), _
DateSelectedColor:=RGB(169, 208, 142), _
TodayFontColor:=RGB(255, 0, 0), _
DateSpecialEffect:=fmSpecialEffectRaised)
Here is a small taste of some of the features it includes. All options are fully documented in the userform module itself:
Ease of use. The userform is completely self-contained, and can be imported into any VBA project and used without much, if any additional coding.
Simple, attractive design.
Fully customizable functionality, size, and color scheme
Limit user selection to a specific date range
Choose any day for the first day of the week
Include week numbers, and support for ISO standard
Clicking the month or year label in the header reveals selectable comboboxes
Dates change color when you mouse over them
Add something to track the length and allow you to do "checks" on whether the user is adding or subtracting text. This is currently untested but something similar to this should work (especially if you have a userform).
'add this to your userform or make it a static variable if it is not part of a userform
private oldLength as integer
Private Sub txtBoxBDayHim_Change()
if ( oldlength > txboxbdayhim.textlength ) then
oldlength =txtBoxBDayHim.textlength
exit sub
end if
If txtBoxBDayHim.TextLength = 2 or txtBoxBDayHim.TextLength = 5 then
txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
end if
oldlength =txtBoxBDayHim.textlength
End Sub
I too, one way or another stumbled on the same dilemma, why the heck Excel VBA doesn't have a Date Picker. Thanks to Sid, who made an awesome job to create something for all of us.
Nonetheless, I came to a point where I need to create my own. And I am posting it here since a lot of people I'm sure lands on this post and benefit from it.
What I did was very simple as what Sid does except that I do not use a temporary worksheet. I thought the calculations are very simple and straight forward so there's no need to dump it somewhere else. Here's the final output of the calendar:
How to set it up:
Create 42 Label controls and name it sequentially and arranged left to right, top to bottom (This labels contains greyed 25 up to greyed 5 above). Change the name of the Label controls to Label_01,Label_02 and so on. Set all 42 labels Tag property to dts.
Create 7 more Label controls for the header (this will contain Su,Mo,Tu...)
Create 2 more Label control, one for the horizontal line (height set to 1) and one for the Month and Year display. Name the Label used for displaying month and year Label_MthYr
Insert 2 Image controls, one to contain the left icon to scroll previous months and one to scroll next month (I prefer simple left and right arrow head icon). Name it Image_Left and Image_Right
The layout should be more or less like this (I leave the creativity to anyone who'll use this).
Declaration: We need one variable declared at the very top to hold the current month selected.
Option Explicit
Private curMonth As Date
Private Procedure and Functions:
Private Function FirstCalSun(ref_date As Date) As Date
'/* returns the first Calendar sunday */
FirstCalSun = DateSerial(Year(ref_date), _
Month(ref_date), 1) - (Weekday(ref_date) - 1)
End Function
Private Sub Build_Calendar(first_sunday As Date)
'/* This builds the calendar and adds formatting to it */
Dim lDate As MSForms.Label
Dim i As Integer, a_date As Date
For i = 1 To 42
a_date = first_sunday + (i - 1)
Set lDate = Me.Controls("Label_" & Format(i, "00"))
lDate.Caption = Day(a_date)
If Month(a_date) <> Month(curMonth) Then
lDate.ForeColor = &H80000011
Else
If Weekday(a_date) = 1 Then
lDate.ForeColor = &HC0&
Else
lDate.ForeColor = &H80000012
End If
End If
Next
End Sub
Private Sub select_label(msForm_C As MSForms.Control)
'/* Capture the selected date */
Dim i As Integer, sel_date As Date
i = Split(msForm_C.Name, "_")(1) - 1
sel_date = FirstCalSun(curMonth) + i
'/* Transfer the date where you want it to go */
MsgBox sel_date
End Sub
Image Events:
Private Sub Image_Left_Click()
If Month(curMonth) = 1 Then
curMonth = DateSerial(Year(curMonth) - 1, 12, 1)
Else
curMonth = DateSerial(Year(curMonth), Month(curMonth) - 1, 1)
End If
With Me
.Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
Build_Calendar FirstCalSun(curMonth)
End With
End Sub
Private Sub Image_Right_Click()
If Month(curMonth) = 12 Then
curMonth = DateSerial(Year(curMonth) + 1, 1, 1)
Else
curMonth = DateSerial(Year(curMonth), Month(curMonth) + 1, 1)
End If
With Me
.Label_MthYr.Caption = Format(curMonth, "mmmm, yyyy")
Build_Calendar FirstCalSun(curMonth)
End With
End Sub
I added this to make it look like the user is clicking the label and should be done on the Image_Right control too.
Private Sub Image_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Image_Left.BorderStyle = fmBorderStyleSingle
End Sub
Private Sub Image_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Image_Left.BorderStyle = fmBorderStyleNone
End Sub
Label Events: All of this should be done for all 42 labels (Label_01 to Lable_42) Tip: Build the first 10 and just use find and replace for the remaining.
Private Sub Label_01_Click()
select_label Me.Label_01
End Sub
This is for hovering over dates and clicking effect.
Private Sub Label_01_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Label_01.BorderStyle = fmBorderStyleSingle
End Sub
Private Sub Label_01_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Label_01.BackColor = &H8000000B
End Sub
Private Sub Label_01_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Me.Label_01.BorderStyle = fmBorderStyleNone
End Sub
UserForm Events:
Private Sub UserForm_Initialize()
'/* This is to initialize everything */
With Me
curMonth = DateSerial(Year(Date), Month(Date), 1)
.Label_MthYr = Format(curMonth, "mmmm, yyyy")
Build_Calendar FirstCalSun(curMonth)
End With
End Sub
Again, just for the hovering over dates effect.
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
With Me
Dim ctl As MSForms.Control, lb As MSForms.Label
For Each ctl In .Controls
If ctl.Tag = "dts" Then
Set lb = ctl: lb.BackColor = &H80000005
End If
Next
End With
End Sub
And that's it. This is raw and you can add your own twist to it.
I've been using this for awhile and I have no issues (performance and functionality wise). No Error Handling yet but can be easily managed I guess. Actually, without the effects, the code is too short. You can manage where your dates go in the select_label procedure. HTH.
Just for fun I took Siddharth's suggestion of separate textboxes and did comboboxes. If anybody's interested, add a userform with three comboboxes named cboDay, cboMonth and cboYear and arrange them left to right. Then paste the code below into the UserForm's code module. The required combobox properties are set in UserFormInitialization, so no additional prep should be required.
The tricky part is changing the day when it becomes invalid because of a change in year or month. This code just resets it to 01 when that happens and highlights cboDay.
I haven't coded anything like this in a while. Hopefully it will be of interest to somebody, someday. If not it was fun!
Dim Initializing As Boolean
Private Sub UserForm_Initialize()
Dim i As Long
Dim ctl As MSForms.Control
Dim cbo As MSForms.ComboBox
Initializing = True
With Me
With .cboMonth
' .AddItem "month"
For i = 1 To 12
.AddItem Format(i, "00")
Next i
.Tag = "DateControl"
End With
With .cboDay
' .AddItem "day"
For i = 1 To 31
.AddItem Format(i, "00")
Next i
.Tag = "DateControl"
End With
With .cboYear
' .AddItem "year"
For i = Year(Now()) To Year(Now()) + 12
.AddItem i
Next i
.Tag = "DateControl"
End With
DoEvents
For Each ctl In Me.Controls
If ctl.Tag = "DateControl" Then
Set cbo = ctl
With cbo
.ListIndex = 0
.MatchRequired = True
.MatchEntry = fmMatchEntryComplete
.Style = fmStyleDropDownList
End With
End If
Next ctl
End With
Initializing = False
End Sub
Private Sub cboDay_Change()
If Not Initializing Then
If Not IsValidDate Then
ResetMonth
End If
End If
End Sub
Private Sub cboMonth_Change()
If Not Initializing Then
ResetDayList
If Not IsValidDate Then
ResetMonth
End If
End If
End Sub
Private Sub cboYear_Change()
If Not Initializing Then
ResetDayList
If Not IsValidDate Then
ResetMonth
End If
End If
End Sub
Function IsValidDate() As Boolean
With Me
IsValidDate = IsDate(.cboMonth & "/" & .cboDay & "/" & .cboYear)
End With
End Function
Sub ResetDayList()
Dim i As Long
Dim StartDay As String
With Me.cboDay
StartDay = .Text
For i = 31 To 29 Step -1
On Error Resume Next
.RemoveItem i - 1
On Error GoTo 0
Next i
For i = 29 To 31
If IsDate(Me.cboMonth & "/" & i & "/" & Me.cboYear) Then
.AddItem Format(i, "0")
End If
Next i
On Error Resume Next
.Text = StartDay
If Err.Number <> 0 Then
.SetFocus
.ListIndex = 0
End If
End With
End Sub
Sub ResetMonth()
Me.cboDay.ListIndex = 0
End Sub
For a quick solution, I usually do like this.
This approach will allow the user to enter date in any format they like in the textbox, and finally format in mm/dd/yyyy format when he is done editing. So it is quite flexible:
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If TextBox1.Text <> "" Then
If IsDate(TextBox1.Text) Then
TextBox1.Text = Format(TextBox1.Text, "mm/dd/yyyy")
Else
MsgBox "Please enter a valid date!"
Cancel = True
End If
End If
End Sub
However, I think what Sid developed is a much better approach - a full fledged date picker control.
You could use an input mask on the text box, too. If you set the mask to ##/##/#### it will always be formatted as you type and you don't need to do any coding other than checking to see if what was entered was a true date.
Which just a few easy lines
txtUserName.SetFocus
If IsDate(txtUserName.text) Then
Debug.Print Format(CDate(txtUserName.text), "MM/DD/YYYY")
Else
Debug.Print "Not a real date"
End If
While I agree with what's mentioned in the answers below, suggesting that this is a very bad design for a Userform unless copious amounts of error checks are included...
to accomplish what you need to do, with minimal changes to your code, there are two approaches.
Use KeyUp() event instead of Change event for the textbox. Here is an example:
Private Sub TextBox2_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim TextStr As String
TextStr = TextBox2.Text
If KeyCode <> 8 Then ' i.e. not a backspace
If (Len(TextStr) = 2 Or Len(TextStr) = 5) Then
TextStr = TextStr & "/"
End If
End If
TextBox2.Text = TextStr
End Sub
Alternately, if you need to use the Change() event, use the following code. This alters the behavior so the user keeps entering the numbers, as
12072003
while the result as he's typing appears as
12/07/2003
But the '/' character appears only once the first character of the DD i.e. 0 of 07 is entered. Not ideal, but will still handle backspaces.
Private Sub TextBox1_Change()
Dim TextStr As String
TextStr = TextBox1.Text
If (Len(TextStr) = 3 And Mid(TextStr, 3, 1) <> "/") Then
TextStr = Left(TextStr, 2) & "/" & Right(TextStr, 1)
ElseIf (Len(TextStr) = 6 And Mid(TextStr, 6, 1) <> "/") Then
TextStr = Left(TextStr, 5) & "/" & Right(TextStr, 1)
End If
TextBox1.Text = TextStr
End Sub
Private Sub txtBoxBDayHim_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then 'only numbers and backspace
If KeyAscii = 8 Then 'if backspace, ignores + "/"
Else
If txtBoxBDayHim.TextLength = 10 Then 'limit textbox to 10 characters
KeyAscii = 0
Else
If txtBoxBDayHim.TextLength = 2 Or txtBoxBDayHim.TextLength = 5 Then 'adds / automatically
txtBoxBDayHim.Text = txtBoxBDayHim.Text + "/"
End If
End If
End If
Else
KeyAscii = 0
End If
End Sub
This works for me. :)
Your code helped me a lot. Thanks!
I'm brazilian and my english is poor, sorry for any mistake.