Issue
I would like to create macro in Excel as below:
When we click the command button, it should prompt for entering the number in the input box.
After inputting the number, it should take us to the cell that has the number and the latter should be filled with current time.
Template is as below:
When I click Command and enter the number 307304 in the input box. it should bring me to the particular cell and the start time should be captured. If I click again end time should be captured. (thesevalues will be used to calculate the current time).
Employee # Start Time End Time
307301
307302
307303
307304
307305
307306
307307
307308
307309
307310
Solution
Try this. The routine to use is doTimeStamp
The idea is that you would connect this routine to the command button. When you click on it, it will ask for emp id and will enter the start date (if it's blank) or end date (if it's blank) and then prompt you again for the next id. It will ask you for id till you enter a blank and that point it will quit.
Option Explicit
Public Sub doTimeStamp()
Dim lRow As Long
Dim sSearchText As String
Dim lEmpID As Long
Dim sTgtSheet As String
'name of the sheet where the ids are
sTgtSheet = "Sheet1"
Do
sSearchText = InputBox("Please Enter the Employee ID", "Time Recording")
sSearchText = Trim(sSearchText)
If (sSearchText = vbNullString) _
Then
'no data was entered. then quit
GoTo Loop_Bottom
End If
If Not (IsNumeric(sSearchText)) _
Then
'text entered was not numeric.
MsgBox "Invalid Employee ID. Employee ID can be only digits. Try Again", vbExclamation + vbOKOnly
GoTo Loop_Bottom
End If
If (InStr(1, sSearchText, ".") > 0) _
Then
'text entered had a decimal.
MsgBox "Invalid Employee ID. Employee ID can be only digits. Try Again", vbExclamation + vbOKOnly
GoTo Loop_Bottom
End If
'locate the row in column 1
lRow = getItemLocation(sSearchText, Sheets(sTgtSheet).Columns(1))
If (lRow = 0) _
Then
'search returned no hit
MsgBox "Employee ID Not Found. Try Again", vbInformation + vbOKOnly
GoTo Loop_Bottom
End If
If (Sheets(sTgtSheet).Cells(lRow, "B") = vbNullString) _
Then
'cell of the found row has column B empty
Sheets(sTgtSheet).Cells(lRow, "B") = Now
ElseIf (Sheets(sTgtSheet).Cells(lRow, "C") = vbNullString) _
Then
'cell of the found row has column C empty
Sheets(sTgtSheet).Cells(lRow, "C") = Now
Else
'cell of the found row has column B and C filled in
MsgBox "Start and End Time has been already recorded for Employee " & sSearchText , vbInformation + vbOKOnly
End If
Loop_Bottom:
' loop till sSearchText is a blank
Loop While (sSearchText <> vbNullString)
End Sub
Public Function getItemLocation(sLookFor As String, _
rngSearch As Range, _
Optional bFullString As Boolean = True, _
Optional bLastOccurance As Boolean = True, _
Optional bFindRow As Boolean = True) As Long
'To locate the first/last row/column within a range for a specific string
Dim Cell As Range
Dim iLookAt As Integer
Dim iSearchDir As Integer
Dim iSearchOdr As Integer
If (bFullString) _
Then
iLookAt = xlWhole
Else
iLookAt = xlPart
End If
If (bLastOccurance) _
Then
iSearchDir = xlPrevious
Else
iSearchDir = xlNext
End If
If Not (bFindRow) _
Then
iSearchOdr = xlByColumns
Else
iSearchOdr = xlByRows
End If
With rngSearch
If (bLastOccurance) _
Then
Set Cell = .Find(sLookFor, .Cells(1, 1), xlValues, iLookAt, iSearchOdr, iSearchDir)
Else
Set Cell = .Find(sLookFor, .Cells(.Rows.Count, .Columns.Count), xlValues, iLookAt, iSearchOdr, iSearchDir)
End If
End With
If Cell Is Nothing Then
getItemLocation = 0
ElseIf Not (bFindRow) _
Then
getItemLocation = Cell.Column
Else
getItemLocation = Cell.Row
End If
Set Cell = Nothing
End Function
Thanks to rizvisa1 for this tip.
