I am taking two input from USERFORM "CheckIn Time (hh:mm format)" and "Checkout Time (hh:mm format)" through TextBox, and trying to get immediate output in 3rd Text Box (hh:mm format) which shows difference between check in and checkout.
To achieve this I am using Call Sub procedure method.
However I am getting error
"Run time 13: Type mismatch".
I am new to VBA and I am literally stuck at this since 2 weeks. Please help.
I tried changing DATA type but didn't get any positive result.
Private Sub CHKIN_Change() 'Calling GetTime
Call GetTime
End Sub
Private Sub CHKOUT_Change() 'Calling GetTime
Call GetTime
End Sub
Private Sub TOTALHRS_Change() 'Calling GetTime
Call GetTime
End Sub
'below Calculating difference b/t Checkin & Checkout, displaying in "TOTALHRS" textbox
Sub GetTime()
Dim Time1, Time2, TotalTime As Date
Time1 = CHKIN.Text
Time2 = CHKOUT.Text
TotalTime = DateDiff("s", Time1, Time2)
TotalTime = Totalhour / 86400
TOTALHRS.Text = Format(Totalhour, "hh:mm")
End Sub
'Using below code to convert checkin and checkout input in hh:mm format.
Private Sub CHKIN_AfterUpdate()
Dim tDate As Date
Dim tString As String
With CHKIN
'Check if user put in a colon or not
If InStr(1, .Value, ":", vbTextCompare) = 0 Then
'If not, make string 4 digits and insert colon
tString = Format(.Value, "0000")
tDate = TimeSerial(Left(tString, 2), Right(tString, 2), 0)
CHKIN.Value = Format(tDate, "HH:MM")
Else
'Otherwise, take value as given
.Value = Format(.Value, "hh:mm")
End If
End With
Exit Sub
End Sub
Desired result wanted: checkout - checkin = hh:mm
Example: 23:20 - 9:35 = 13:45
Related
This is what my sheet looks like:
(I got the code from online somewhere & just been adjust what I know)
I Currently have 10 rows with working buttons, but it's already at 500+ lines of code and I still need 60more. I'm worried the file will become too large and start crashing.
Should I just keep changing the "Range(F#)" every time I make a new button/row?
Also, is it possible to keep more than 1 timer going at a time? Currently when I click stop on any of the rows it will stop whatever timer is active.
Public StopIt As Boolean
Public ResetIt As Boolean
Public LastTime
Private Sub cust10reset_Click()
Range("F10").Value = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
LastTime = 0
ResetIt = True
End Sub
Private Sub cust10start_Click()
Dim StartTime, FinishTime, TotalTime, PauseTime
StopIt = False
ResetIt = False
If Range("F10") = 0 Then
StartTime = Timer
PauseTime = 0
LastTime = 0
Else
StartTime = 0
PauseTime = Timer
End If
StartIt:
DoEvents
If StopIt = True Then
LastTime = TotalTime
Exit Sub
Else
FinishTime = Timer
TotalTime = FinishTime - StartTime + LastTime - PauseTime
TTime = TotalTime * 100
HM = TTime Mod 100
TTime = TTime \ 100
hh = TTime \ 3600
TTime = TTime Mod 3600
MM = TTime \ 60
SS = TTime Mod 60
Range("F10").Value = Format(hh, "00") & ":" & Format(MM, "00") & ":" & Format(SS, "00") & "." & Format(HM, "00")
If ResetIt = True Then
Range("F10") = Format(0, "00") & ":" & Format(0, "00") & ":" & Format(0, "00") & "." & Format(0, "00")
LastTime = 0
PauseTime = 0
End
End If
GoTo StartIt
End If
End Sub
Private Sub cust10stop_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
StopIt = True
End Sub
I tried making a dedicated formula tab and just make macros going my timer buttons but I couldn't get that to work.
I tried making a togglebutton and linking it to the cell then just make a code that references the linkedcell to know where to put the timer, but that wasn't working. It just kept coming back true/false.
I guess I just want to know if it's ok to have 4000+ lines on 1 sheet with 210 buttons lol.
Or just an easier way.
Here's one approach using hyperlinks in place of buttons:
The hyperlinks you create need to have a destination, but in this case we want "do nothing" links - their only purpose is to trigger the sheet's FollowHyperlink event
This post
excel hyperlink to nothing
has suggestion for approaches to a "do nothing" hyperlink. Entering #rc for the address seems to work well - as explained by lori_m in their comment -
The # signifies a reference within a document and any formula that
returns a reference can follow in either A1 or r1c1 notation. Here rc
means this cell in r1c1notation.
Set up some links using "Insert >> Hyperlink", using "#rc" as the link target (entered next to "Address").
Don't use the HYPERLINK() formula, because those types of links don't trigger the FollowHyperlink event.
For example (3 timers running):
Finally this code goes in the worksheet code module:
Option Explicit
Dim timers As Object 'cell addresses as keys and start times as values
Dim nextTime 'next run time
'This is called when youclickon a hyperlink
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Dim txt As String, cLnk As Range, cTimer As Range, addr As String
Dim currVal
If timers Is Nothing Then Set timers = CreateObject("scripting.dictionary")
Set cLnk = Target.Range 'cell with clicked link
Set cTimer = cLnk.EntireRow.Columns("B") 'cell with elapsed time
addr = cTimer.Address(False, False) 'address of cell with elapsed time
txt = Target.TextToDisplay 'Start/Stop/Reset
Select Case txt 'what action to take depends on the link's text
Case "Stop"
If timers.Exists(addr) Then timers.Remove addr
Target.TextToDisplay = "Start" 'toggle link text
cLnk.Interior.Color = vbGreen 'toggle cell color
Case "Start"
currVal = cTimer.Value 'already some elapsed value?
timers(addr) = IIf(Len(currVal) > 0, Now - currVal, Now)
Target.TextToDisplay = "Stop"
cLnk.Interior.Color = vbRed
Case "Reset"
If timers.Exists(addr) Then 'timer is running?
timers(addr) = Now 'just reset the start time
Else
cTimer.Value = 0 'clear the elapsed time
End If
End Select
UpdateTimers
End Sub
'called using OnTime, or from the event handler
Sub UpdateTimers()
Dim addr As String, k, macro
macro = Me.CodeName & ".UpdateTimers"
On Error Resume Next 'cancel any running timer
Application.OnTime EarliestTime:=nextTime, Procedure:=macro, Schedule:=False
On Error GoTo 0
If timers.Count = 0 Then Exit Sub 'no more timers
For Each k In timers 'update timer(s)
Me.Range(k).Value = Format(Now - timers(k), "hh:mm:ss")
Next k
nextTime = Now + TimeSerial(0, 0, 1) 'schedule next run
Application.OnTime nextTime, macro
End Sub
What you could consider is to work with a Class module and a dictionary.
The Timer() command in XL merely generates a TimeStamp value that you can store for later use. You could do that in a dictionary with a particular class.
Create a Class module and name it cTimer add below code
Option Explicit
Private pTimer As Single
Public Sub StartTimer()
pTimer = Timer()
End Sub
Property Get Elapsed() As Single
Elapsed = Timer() - pTimer
End Property
Now, mind you, the portion of using the class may not strictly be required as you could simply add a dictionary entry for the address and Timer() value.
like so:
dict.Add Key, Timer()
But working with a class object allows you to create more functionality for each of the cTimer objects.
Now, to keep track of all the timers you can set add a new cTimer object to the dictionary based on the cell address of the button (this may need some fine tuning to ensure all your buttons eventually generate the same reference key)
But that is the most important portion of it, the reference key.
In a code module, add the below, this will look for an existing entry in the dictionary and if it exists display the elapsed time otherwise a new cTimer object will be added to the dictionary with the address as the reference key.
Create a Module and add the following:
Global dict As Object 'this line should be all the way at the top of the module code!
Sub TestTimer()
Dim rngButton As Range
Dim mm As cTimer
If dict Is Nothing Then
Set dict = CreateObject("Scripting.Dictionary")
End If
Caller = Application.Caller
Set rngButton = ActiveSheet.Buttons(Caller).TopLeftCell
Key = rngButton.Address
Set tmr = New cTimer
tmr.StartTimer
If Not dict.Exists(Key) Then
dict.Add Key, tmr
Else
Set tmr = dict(Key)
Debug.Print tmr.Elapsed
End If
End Sub
This may obviously need some tweaking to suit your particular need, but this could well be the solution you aim for. As you can simply have all the buttons refer to the same Method (or Macro)
You should add some logic for removing times and for resetting them etc. but the concept works.
see also: https://learn.microsoft.com/en-us/office/vba/Language/Reference/User-Interface-Help/dictionary-object
I'm setting up a userform for employees to fill in data. They need to fill in the date like DD-MM-YYYY the output must also be DD-MM-YYYY. However the code I use changes input 5-12-2019 (DD-MM-YYYY), to output 12-5-2019 (MM-DD-YYYY). In the userform it stays like (DD-MM-YYYY) expect for when you tranfer it to your excel sheet. If the month is above 13 it doesn't change, so input 13-12-2019 (DD-MM-YYYY) stays output 13-12-2019 (DD-MM-YYYY). How is it possible that the code changes the output but not everytime the same way, did I do something wrong in the code?
Private Sub TextBox1_BeforeUpdate(ByVal cancel As MSForms.ReturnBoolean)
If IsDate(Me.TextBox1.Text) Then
Me.TextBox1.Text = Format(Me.TextBox1.Text, "DD-MM-YYYY")
Else
MsgBox "Vul een geldige datum in", vbRetryCancel + vbCritical
End If
End Sub
Public Function IsTime(Expression As Variant) As Boolean
If IsDate(Expression) Then
IsTime = (Int(CSng(CDate(Expression))) = 0)
End If
End Function
Read the date as a string. E.g. 5-12-2009.
Split the string by -.
The 0th value is the day, the 1st is the month, the 2nd is the year.
From there, you have a fully functioning date, using DateSerial().
Public Function StringToDate(myInput As String) As Date
Dim day As Long
Dim month As Long
Dim year As Long
Dim dateArray As Variant
dateArray = Split(myInput, "-")
day = dateArray(0)
month = dateArray(1)
year = dateArray(2)
StringToDate = DateSerial(year, month, day)
End Function
Public Sub Main()
Debug.Print month(StringToDate("05-10-2001"))
Debug.Print StringToDate("05-10-2001")
End Sub
I know that we can use function Date in forms for the insertion of the date. But for some dates (such as Hijri Shamsi and Hijri lunar history, etc.), this is impossible and difficult. So I wrote a code that works with the text box. But I think the code that I wrote can be simpler. Do you have a solution to make it simpler?
For example: checking the slash or preventing of Double message display for the moon and day error.
Thanks in advance for the friends who respond.
Private Sub TextBox1_Change()
'To check the slash in the correct place
If Mid(TextBox1, 1) = "/" Or Mid(TextBox1, 2) = "/" Or Mid(TextBox1, 3) = "/" Or Mid(TextBox1, 4) = "/" Or Mid(TextBox1, 6) = "/" Or Mid(TextBox1, 7) = "/" Or Mid(TextBox1, 9) = "/" Or Mid(TextBox1, 10) = "/" Then
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
SendKeys ("{BACKSPACE}")
End If
'Insert the slash automatically
If TextBox1.TextLength = 8 Then
Me.TextBox1.Value = Format(Me.TextBox1.Value, "0000/00/00")
End If
'Year Error!
If Mid(TextBox1, 4) = 0 Then
MsgBox "Year Error!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 0
.SelLength = Len(.Text)
End With
Exit Sub
End If
'Month Error!
If TextBox1.TextLength = 10 Then
If Mid(TextBox1.Value, 6, 2) = 0 Or Mid(TextBox1.Value, 6, 2) > 12 Then
MsgBox "Month Error!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 5
.SelLength = 2
'.SelText = ""
End With
Exit Sub
End If
End If
'Day Error!
If TextBox1.TextLength = 10 Then
If Mid(TextBox1.Value, 9, 2) = 0 Or Mid(TextBox1.Value, 9, 2) > 31 Then
MsgBox "Day Error!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 8
.SelLength = 2
End With
Exit Sub
End If
End If
End Sub
Private Sub textbox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Accept only number and slash
If Not Chr(KeyAscii) Like "[0-9,/ ]" Then
KeyAscii = 0
MsgBox "Only Numbers Allowed!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SetFocus
Exit Sub
End With
End If
End Sub
I am not familiar enough with the calendar forms you're dealing with, so please understand my example based on a western-style calendar.
The way you're performing some of your error checking somewhat obscures the values you'e checking. For example,
If Mid(TextBox1.Value, 6, 2) = 0 Or Mid(TextBox1.Value, 6, 2) > 12 Then
is a perfectly valid check, but you're overusing the Mid function. One suggestion is to parse the date string and pull out substrings into values you're looking for. As in:
Dim month As Long
month = CLng(Mid$(TextBox1.Value, 6, 2))
If (month = 0) Or (month > 12) Then
this makes more intuitive sense. Yes, it creates an extra variable, but it makes your code much more readable.
Here's my (untested) version of your code as another example of how it can be done. Notice that I'm separating the error checking into a separate function because it's more involved. (This way it isn't cluttering the main routine.)
EDIT: Answer has been updated and tested. Changed the event code from TextBox1_Change and now catching two different events: LostFocus and KeyDown in order to kick off a validation when the user clicks away from the textbox or types Enter while in the textbox.
Option Explicit
Private Enum ValidationError
LengthError
FormatError
YearError
MonthError
DayError
NoErrors
End Enum
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
If KeyCode = Asc(vbCr) Then
ValidateDate
End If
End Sub
Private Sub TextBox1_LostFocus()
ValidateDate
End Sub
Private Sub ValidateDate()
With TextBox1
Select Case InputIsValidated(.text)
Case LengthError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case FormatError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case YearError
.SelStart = 0
.SelLength = 4
MsgBox "Invalid Year. Must be between 2015 and 2020"
Case MonthError
.SelStart = 5
.SelLength = 2
MsgBox "Invalid Month. Must be between 1 and 12"
Case DayError
.SelStart = 7
.SelLength = 2
MsgBox "Invalid Day. Must be between 1 and 31"
Case NoErrors
'--- nothing to do, it's good!
MsgBox "It's good!"
End Select
End With
End Sub
Private Function InputIsValidated(ByRef text As String) As ValidationError
'--- perform all sorts of checks to validate the input
' before any processing
'--- MUST be the correct length
If (Len(text) <> 8) And (Len(text) <> 10) Then
InputIsValidated = LengthError
Exit Function
End If
'--- check if all characters are numbers
Dim onlyNumbers As String
onlyNumbers = Replace(text, "/", "")
If Not IsNumeric(onlyNumbers) Then
InputIsValidated = FormatError
Exit Function
End If
Dim yyyy As Long
Dim mm As Long
Dim dd As Long
yyyy = Left$(onlyNumbers, 4)
mm = Mid$(onlyNumbers, 5, 2)
dd = Right$(onlyNumbers, 2)
'--- only checks if the numbers are in range
' you can make this more involved if you want to check
' if, for example, the day for February is between 1-28
If (yyyy < 2015) Or (yyyy > 2020) Then
InputIsValidated = YearError
Exit Function
End If
If (mm < 1) Or (mm > 12) Then
InputIsValidated = MonthError
Exit Function
End If
If (dd < 1) Or (dd > 31) Then
InputIsValidated = DayError
Exit Function
End If
text = onlyNumbers
InputIsValidated = NoErrors
End Function
Thanks to #PeterT, I corrected the code with guidance #PeterT and I give it to all the interested people. Enjoy it.
Option Explicit
Private Enum ValidationError
LengthError
FormatError
YearError
MonthError
DayError
NoErrors
End Enum
Private Sub TextBox1_Change()
'To check the slash in the correct place
If TextBox1.TextLength = 10 Then
If InStr(Left(TextBox1, 4), "/") Or InStr(Mid(TextBox1, 6, 2), "/") Or InStr(Mid(TextBox1, 9, 2), "/") <> 0 Then
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
With TextBox1
.SelStart = 0
.SelLength = Len(.text)
End With
End If
End If
'Insert the slash automatically
If TextBox1.TextLength = 8 Then
If InStr(TextBox1, "/") Then
'nothing
Else
Me.TextBox1.Value = Format(Me.TextBox1.Value, "0000/00/00")
End If
End If
End Sub
Private Sub textbox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Accept only number and slash
If Not Chr(KeyAscii) Like "[0-9,/ ]" Then
KeyAscii = 0
MsgBox "Only Numbers Allowed!" & vbNewLine & "Please insert date with format: YYYYMMDD or YYYY/MM/DD"
End If
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = Asc(vbCr) Then
ValidateDate
End If
End Sub
Private Sub TextBox1_LostFocus()
ValidateDate
End Sub
Private Sub ValidateDate()
With TextBox1
Select Case InputIsValidated(.text)
Case LengthError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case FormatError
MsgBox "Please insert date with format: YYYYMMDD or YYYY/MM/DD with only numbers and a '/'"
Case YearError
.SelStart = 0
.SelLength = 4
MsgBox "Invalid Year. Must be between 2015 and 2020"
Case MonthError
.SelStart = 5
.SelLength = 2
MsgBox "Invalid Month. Must be between 1 and 12"
Case DayError
.SelStart = 8
.SelLength = 2
MsgBox "Invalid Day. Must be between 1 and 31"
Case NoErrors
'--- nothing to do, it's good!
MsgBox "It's good!"
End Select
End With
End Sub
Private Function InputIsValidated(ByRef text As String) As ValidationError
'--- perform all sorts of checks to validate the input
' before any processing
'--- MUST be the correct length
If InStr(TextBox1, "/") And TextBox1.TextLength < 10 Then
InputIsValidated = FormatError
Exit Function
End If
Dim yyyy As Long
Dim mm As Long
Dim dd As Long
yyyy = Left$(TextBox1, 4)
mm = Mid$(TextBox1, 6, 2)
dd = Right$(TextBox1, 2)
'--- only checks if the numbers are in range
' you can make this more involved if you want to check
' if, for example, the day for February is between 1-28
If (yyyy < 2015) Or (yyyy > 2020) Then
InputIsValidated = YearError
Exit Function
End If
If (mm < 1) Or (mm > 12) Then
InputIsValidated = MonthError
Exit Function
End If
If (dd < 1) Or (dd > 31) Then
InputIsValidated = DayError
Exit Function
End If
text = TextBox1
InputIsValidated = NoErrors
End Function
Excel keeps changing my date to US format. I have a user form where the user inputs a date. As an example, I enter 01/11/2018 (1st November 2018). I then put this value into a cell however it changes automatically to 11/01/2018 or 11th January 2018.
I've so far tried using the following code to force it to use UK format;
SHT_data_TASKS.Cells(1 + tableRows, 8).NumberFormat = "dd/mm/yyyy;#"
SHT_data_TASKS.Cells(1 + tableRows, 8) = form_addTask_Date.Value
But it does not help. I've also tried using CDate function but still no luck. I've checked my computer regional settings and they are all correct for the UK.
If I right click on the cell where the date is placed and chose format it shows as already being formatted to UK date! I'm not sure what is causing it to change.
This is the date code I use on control containing UK dates:
Private Sub UserForm_Initialize()
Me.txtDate = Format(Date, "dd-mmm-yyyy")
End Sub
On the AfterUpdate event for the date control:
Private Sub txtDate_AfterUpdate()
With Me
FormatDate .txtDate
End With
End Sub
In a normal module:
Public Sub FormatDate(ctrl As Control)
Dim dDate As Date
Dim IsDate As Boolean
If Replace(ctrl.Value, " ", "") <> "" Then
On Error Resume Next
dDate = CDate(ctrl.Value)
IsDate = (Err.Number = 0)
Err.Clear
On Error GoTo 0
If IsDate Then
ctrl.Value = Format(ctrl.Value, "dd-mmm-yyyy")
ctrl.BackColor = RGB(255, 255, 255)
Else
ctrl.BackColor = RGB(255, 0, 0)
End If
End If
End Sub
Then I transfer it to the worksheet (on a Save button) using the below code:
shtRawData.Cells(rLastCell.Row, CLng(lCol)) = CDate(ctrl.Value)
When you're about to write your date to the sheet:
Verify that it's being stored as a date (or date equivalent) with isdate()
Assign it via Range.FormulaLocal instead of value or value2.
Untested, but i.e.
Range("A1").FormulaLocal = #10/31/2018#
I have a small user interface, using Excel's Form functionality, which allows users to input start and finish dates for projects.
If the user puts in dates that are available in both the US and UK formats (e.g. 7th May 2018, 5/7/2018) the variable will come out in the US format (e.g. 5th July 2018, 5/7/2018). However, if the dates are not available in both formats (e.g. 31st August 2018, 31/8/2018), the variable will return in the (correct) UK format.
My current code for the particular variables in the form is as follows:
Private Sub Calculate_Click()
sDate = CDate(sDate.Text)
eDate = CDate(eDate.Text)
If sDate = vbNullString Then
sDate = Now()
End If
If eDate = vbNullString Then
eDate = Now() + 40
End If
If HoursPD = vbNullString Then
HoursPD = 6
ElseIf HoursPD > 7.5 Then
HoursPD = 7.5
End If
Me.Hide
End Sub
Is there any way to ensure that the variable format is fixed to the UK version?
I'd use a separate procedure to check any dates on the form.
This also colours the control red if a non-valid date is entered.
Formatting the date as dd-mmm-yyyy makes it easier to spot a date in the wrong format as month is written in full(ish).
Public Sub FormatDate(ctrl As Control)
Dim dDate As Date
Dim IsDate As Boolean
On Error GoTo ERR_HANDLE
If Replace(ctrl.Value, " ", "") <> "" Then
On Error Resume Next
dDate = CDate(ctrl.Value)
IsDate = (Err.Number = 0)
On Error GoTo 0
On Error GoTo ERR_HANDLE
If IsDate Then
ctrl.Value = Format(ctrl.Value, "dd-mmm-yyyy")
ctrl.BackColor = RGB(255, 255, 255)
Else
ctrl.BackColor = RGB(255, 0, 0)
End If
End If
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
'Error Handling routines.
'DisplayError Err.Number, Err.Description, "mdl_FormatDate.FormatDate()"
Resume EXIT_PROC
End Sub
This is then called on the AfterUpdate event of the control:
Private Sub txtDate_AfterUpdate()
On Error GoTo ERR_HANDLE
With Me
FormatDate .txtDate
End With
EXIT_PROC:
On Error GoTo 0
Exit Sub
ERR_HANDLE:
'Error Handling routines.
'DisplayError Err.Number, Err.Description, "Data_Entry_Form.txtDate_AfterUpdate()"
Resume EXIT_PROC
End Sub
You could do something like below, but your users should know to enter the dates in the correct (UK) format:
sDate = Format(CDate(sDate.Text), "dd/mm/yyyy")
EDate = Format(CDate(EDate.Text), "dd/mm/yyyy")