I have a a MS access table (MasterLogs)with structure as Date, UserName, Position, loginTime, logoutTime.(Login and logout field type is date&time)
I want to extract data from this table to another table (PositionHrs)where the columns are
Date
Username
Position
0000-0059
0100-0159
0200-0259
...
until 2300-2359 (which are basically like time duration).
In the Masterlogs table, the records are like 01-Aug-17, Username, position and there will be login logout times (eg:login 01-Aug-17 00:05 and logout time 01-Aug-17 02:45)
I am looking for a VBA code which can read the records in masterlogs and split the minutes of duration to corresponding column in the positionHrs table.
So that table should have a record for the username in 0000-0059 column with a value of 00:54 (54 minutes duration during 0000 to 0059 time and in the 0100-0159 column 01:00 and in the 0200-0259 column the remaining duration 00:45
Hope I have explained well.
Can anyone please help me to fix this ?
Thank you for responding braX. The below code add a record with duration for each person in the corresponding hour. if the person has continuous duration in the next hours it doesn't add those duration to corresponding hour columns.
Sub HourlyDuration()
Dim rs1 As Recordset
Dim rs2 As Recordset
Set rs1 = CurrentDb.OpenRecordset("MasterLogs")
Set rs2 = CurrentDb.OpenRecordset("PositionHrs")
Do While Not rs1.EOF
'below for adding minutes in rs2![0000-0059] "hour1"
If Format(rs1![On], "hh:nn") >= #12:00:00 AM# And Format(rs1![On], "hh:nn") <= #12:59:59 AM# Then
Dim St As String
St = Format(TimeValue("01:00:00") - TimeValue(RoundTime(rs1!On, 60)), "hh:nn")
'roundtime is a function to round time to the next minute (time field is dd-mmm-yy hh:nn:ss)
rs2.AddNew
rs2![Date] = rs1![Date]
rs2![0000-0059] = St
rs2!Position = rs1!Position
' rs2!Staff = rs1!Staff
rs2.Update
End If
'for rs2![0100-0159] "hour2"
If Format(rs1![On], "hh:nn") >= #1:00:00 AM# And Format(rs1![On], "hh:nn") <= #1:59:59 AM# Then
Dim st1 As String
st1 = Format(TimeValue("02:00:00") - TimeValue(RoundTime(rs1!On, 60)), "hh:nn")
rs2.AddNew
rs2![Date] = rs1![Date]
rs2![0100-0159] = st1
rs2!Position = rs1!Position
'rs2!Staff = rs1!Staff
rs2.Update
End If
' same conditions repeated for all hours, and then
rs1.MoveNext
Loop
MsgBox ("Finished")
rs1.Close
Set rs1 = Nothing
rs2.Close
Set rs2 = Nothing
End sub
Related
I have too many meetings at work, so I thought I might use an Outlook VBA macro to block my calendar when I have too many meetings, so I can use the rest of the time to actually get things done.
`Sub BlockMoreCalendarAppts()
Dim myAcct As Outlook.Recipient
Dim myFB As String
Dim tDate As Date
Dim d As Long
Dim i As Long
Dim test As String
Dim oAppt As AppointmentItem
' it needs to know whose FB to check
Set myAcct = Session.CreateRecipient("name.lastname#domain.com")
' days to check
For d = 0 To 5
tDate = Date + d
' use start of working day or there about
' false counts tenetive and oof as busy
myFB = myAcct.FreeBusy(tDate + #9:30:00 AM#, 5, False)
' this gets the # of 5 min periods before the start time
i = (TimeValue(tDate + #9:30:00 AM#) * 288)
' only count free busy for 7:10 hours from start + at least 1 additional 5 min period
' # of min in working day / 5
' skips busy times in the evening
test = Mid(myFB, i, 435 / 5)
CountOccurrences = UBound(Split(test, "1")) ' busy, oof or tentative
' theoretical WHERE statement goes here?
CountO = UBound(Split(test, "0")) ' free
'round to hours for subject
times = Round(((CountOccurrences * 5) / 60), 2)
' create all day busy event
' there are 12 5 minute periods per hour
' 60 = 5 hours
If CountOccurrences >= 60 Then
' default calendar
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = times & " hours of appt today"
.Start = tDate
.ReminderSet = False
.Categories = "Full Day"
.AllDayEvent = True
.BusyStatus = olBusy
.Save
End With
End If
' check next day
Next d
End Sub`
The logic is that if I have more than 5 hours of meetings in a day, it sets an all day appointment and marks me as busy.
I tested the attached macro, which works, but, I want to filter out appointments which contain certain words in the subject. For example, "Lunch" or "Focus". In other words, I don't want "Lunch" to be counted in my five hours of meetings.
I have not figured out how to use a WHERE function to filter particular appointments for that day. Any help would be appreciated.
This is based (heavily) on the great work of Diane Poremsky at https://www.slipstick.com/outlook/calendar/limit-number-appointments-day/
If you switch to looping through appointments then you could add them all up like that? Pseudocode:
' Set the start and end times for the day
Dim startTime As Date
startTime = DateSerial(year, month, day) + TimeValue("9:00 AM")
Dim endTime As Date
endTime = DateSerial(year, month, day) + TimeValue("5:00 PM")
' Set the search criteria for the appointments
Dim filter As String
filter = "[Start] >= '" & startTime & "' AND [End] <= '" & endTime & "'" & _
"AND [Subject] NOT Like '*focus*'"
' Get the calendar folder for the default account
Dim calendarFolder As Folder
Set calendarFolder = Application.Session.GetDefaultFolder(olFolderCalendar)
' Set the current appointment to the first appointment of the day
Dim currentAppointment As AppointmentItem
Set currentAppointment = calendarFolder.Items.Find(filter)
' Loop through all appointments on the day
Do While Not (currentAppointment Is Nothing)
' Process the current appointment
' ...
' Get the next appointment
Set currentAppointment = calendarFolder.Items.FindNext
Loop
I found VBA code that checks my schedule and creates an all-day 'busy' appointment if I exceed a certain amount of time in meetings on a given day.
The code works, but creates a duplicate event each time it runs.
I want to add a condition to see if an event already exists with the subject line "%hours of appt today" to prevent duplicate calendar events.
Sub BlockMoreCalendarAppts()
Dim myAcct As Outlook.Recipient
Dim myFB As String
Dim tDate As Date
Dim d As Long
Dim i As Long
Dim test As String
Dim oAppt As AppointmentItem
' it needs to know whose FB to check. Set this as your email address
Set myAcct = Session.CreateRecipient("myemailaddress")
' days to check (checks calendar for (7) days from todays date)
For d = 0 To 7
tDate = Date + d
' use start of working day or there about
' false counts tenetive and oof as busy
myFB = myAcct.FreeBusy(tDate + #7:30:00 AM#, 5, False)
' this gets the # of 5 min periods before the start time
i = (TimeValue(tDate + #7:30:00 AM#) * 288)
' only count free busy for 9 hours from start + at least 1 additional 5 min period
' (in my example, my day starts at 7:30 and ends at 4:30, so counting 9 hours)
' # of min in working day / 5
' skips busy times in the evening
test = Mid(myFB, i, 545 / 5)
CountOccurrences = UBound(Split(test, "1")) 'busy, oof or tentative
CountO = UBound(Split(test, "0")) ' free
'round to hours for subject
times = Round(((CountOccurrences * 5) / 60), 2)
' create all day busy event when I am scheduled
' to be in meetings for 5 or more hours per day
' there are 12 5 minute periods per hour
' 60 = 5 hours, 48 = 4 hours, 72 = 6 hours
If CountOccurrences >= 60 Then
' check to make sure an all day event wasn't already created
' to mark a day as busy
' default calendar
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = times & " hours of appt today"
.Start = tDate
.ReminderSet = False
.Categories = "Full Day"
.AllDayEvent = True
.BusyStatus = olBusy
.Save
End With
I am using this code to search for appointments on a specific date and with a specific subject.
Public objCalendar As Outlook.folder
Public CalendarItems As Outlook.Items
Public oAppt As Outlook.AppointmentItem
Function Calendar_ApptExists(appt_Date As Date, appt_subject$) As Boolean
Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set CalendarItems = objCalendar.Items
' Items in calendar
Debug.Print "Items in Calendar: " & CalendarItems.Count
' Search calendar
For Each oAppt In CalendarItems
Debug.Print oAppt.Start, oAppt.Subject
' Check is appointment already exists
If (Int(oAppt.Start) = appt_Date) And oAppt.Subject = appt_subject Then
MsgBox "Already exists an appointment with '" & oAppt.Subject & "'", vbExclamation
Calendar_ApptExists = True
Exit Function
End If
Next
End Function
The code works, but creates a duplicate event each time it runs.
That is because in the code you create a new appointment item:
' default calendar
Set oAppt = Application.CreateItem(olAppointmentItem)
With oAppt
.Subject = times & " hours of appt today"
.Start = tDate
.ReminderSet = False
.Categories = "Full Day"
.AllDayEvent = True
.BusyStatus = olBusy
.Save
End With
Instead, you need to use Find/FindNext or Restrict methods of the Items class to find any appointment for the specified time frame. Read more about these methods in the following articles:
How To: Retrieve Outlook calendar items using Find and FindNext methods
How To: Use Restrict method in Outlook to get calendar items
I am using VB.NET. I have a dropdownlist named startTimeDDL. Than I am using loop to enter in time inside that dropdownlist.
' Auto fill "Start Time" for DropDownList
Dim StartTime As DateTime = #12:00:00 AM#
For i As Integer = 0 To 47
StartTimeDDL.Items.Add(StartTime.ToString("hh:mm tt"))
StartTime = DateAdd(DateInterval.Minute, 30, StartTime)
Next
So look below and that will be inside the dropdownList. notie the format is hh:mm am/pm.
12:00 AM
12:30 AM
01:00 AM
01:30 AM
02:00 AM
...
11:30 PM
Problem:
lets say current time is 1:21:01 pm than I want to write code so it select 1:30 pm from dropdownlist. Now les take another example. les say current time is 12:00:00 AM than I was to select 12:30 AM from dropdownlist. les take one last example. les say current time is 2:10:12 AM than I want to select 2:30 AM from the dropdownlist.
here is the code I wrote so far. problem with it is that I am only selecting the current time. now can I modfily to do what I want?
Dim dDate As DateTime = DateTime.Now.ToString("hh:mm tt")
Dim temp As String = dDate
StartTimeDDL.Items.FindByValue(temp).Selected = True
Round up if the minute value exceeds 30, round down if it's lower.
Here is an example implementation, you'll need to decide what to do with the "exactly 30 minutes past the hour" edge case. In my code it'll round up for that too.
Private Function RoundDateToHalfHours() As Date
Dim current As DateTime = DateTime.Now
Dim ts As TimeSpan
If current.Minute >= 30 Then
ts = New TimeSpan(current.Hour + 1, 0, 0)
Else
ts = New TimeSpan(current.Hour, 30, 0)
End If
Return current.Date.AddTicks(ts.Ticks)
End Function
Usage:
Dim roundedDate As DateTime = RoundDateToHalfHours()
StartTimeDDL.Items.FindByValue(roundedDate.ToString("hh:mm tt")).Selected = True
You are playing fast and loose with DateTime when you should be using TimeSpan, some caution required. The general way to round up an integral number to an arbitrary interval is
roundedUp = interval * ((number + interval - 1) \ interval)
Which you can readily use on DateTime as well by converting it to ticks, a one-liner
Public Function RoundupDate(dt As DateTime, interval As TimeSpan) As DateTime
Return New DateTime(interval.Ticks * ((dt.Ticks + interval.Ticks - 1) \ interval.Ticks))
End Function
Sample usage:
Dim example = #2:10:12 AM#
Dim rounded = RoundupDate(example, TimeSpan.FromMinutes(30))
Wasn't sure what you meant by a 'dropdownList'. For this example I used a ComboBox.
Dim StartTime As DateTime = #12:00:00 AM#
'load combo box
Do
StartTimeDDL.Items.Add(StartTime.ToString("hh:mm tt"))
StartTime = StartTime.AddMinutes(30)
Loop While StartTime.TimeOfDay.TotalDays > 0
Dim selectTime As DateTime = #2:10:12 PM# 'TEST find this <<<<<<<<<<<<<<<<<<<
'round time to 30 minutes
Dim numSecs As Integer = (CInt(selectTime.TimeOfDay.TotalSeconds) \ 1800) * 1800
'the OP said 'les say current time is 12:00:00 AM than I was to select 12:30 AM"
'so....
numSecs += 1800 'round up 30 minutes ????????
'create 'find'
Dim ts As New TimeSpan(0, 0, numSecs)
Dim findDate As New DateTime(ts.Ticks)
StartTimeDDL.SelectedIndex = StartTimeDDL.FindStringExact(findDate.ToString("hh:mm tt"))
Hello I have this program that lets you start and stop time on a job the problem I am having now is that if it switches from A.M to P.M while time is tracked the program doesn't work right. so I have a button that puts the Time.Now when its pressed in a excel cell than when you stop the job it puts the End time in another cell and then it go's in and grabs the two cells and subtracts them. what I need it to do is put the Date and Time in the cell then both and only give me the Minutes and hours that it took. here is what I have for code.
'This code is for when you start the job.
'which this is only hours and minutes prob should be
'Date and Time
Dim StartTime As String = DateTime.Now.ToString("h\:mm")
'This line of code puts it in an excel cell
oXL.ActiveCell.Offset(0, 13).Value = StartTime
'This code is for when you end a Job.
'Again its only hours and minutes but prob should be
'Date and Time
Dim EndTime As String = DateTime.Now.ToString("h\:mm")
'This is the Total Time I am going to have
'I used TimeSpan
Dim TotalTime As TimeSpan
'Now this is where I put the End time when the
'Button is clicked.
oXL.ActiveCell.Offset(0, 14).Value = EndTime
'Once Both cells have the start and end Times I get them both with this code.
'Again this should prob be Date and Time.
Dim time1 = TimeSpan.ParseExact(oXL.ActiveCell.Offset(0, 13).Value, "h\:mm", CultureInfo.CurrentCulture)
Dim time2 = TimeSpan.ParseExact(oXL.ActiveCell.Offset(0, 14).Value, "h\:mm", CultureInfo.CurrentCulture)
'I then use this code to do my math.
TotalTime = time2 - time1
The Total time I need i only to be the hour an minutes that it took to do the job.
You are taking two dates, converting them and storing them into string variables, then reading them back into dates to calculate. You are hoping that they are in the right format when you parse them back, this in itself is top heavy. But why store dates as string at all? You can convert a date to a string at any time on the fly with the .ToString() method. Just keep them as dates and write them out to the excel sheet as strings when needed. The values will be the same either way, and you're not relying on your sheet to have the data in the adjacent locations, you will just perform the calculation and you are done.
'This code is for when you start the job.
'which this is only hours and minutes prob should be
'Date and Time
Dim StartTime As DateTime = DateTime.Now
'This line of code puts it in an excel cell
oXL.ActiveCell.Offset(0, 13).Value = StartTime.ToString("h\:mm")
'This code is for when you end a Job.
'Again its only hours and minutes but prob should be
'Date and Time
Dim EndTime As DateTime = DateTime.Now
'Now this is where I put the End time when the
'Button is clicked.
oXL.ActiveCell.Offset(0, 14).Value = EndTime.ToString("h\:mm")
'Once Both cells have the start and end Times I get them both with this code.
'Again this should prob be Date and Time.
' Dim time1 = TimeSpan.ParseExact(oXL.ActiveCell.Offset(0, 13).Value, "h\:mm", CultureInfo.CurrentCulture)
' Dim time2 = TimeSpan.ParseExact(oXL.ActiveCell.Offset(0, 14).Value, "h\:mm", CultureInfo.CurrentCulture)
'This is the Total Time I am going to have
'I used TimeSpan
Dim TotalTime As TimeSpan
'I then use this code to do my math.
TotalTime = EndTime.Subtract(StartTime)
'output time difference
MsgBox(TotalTime.ToString)
.:EDIT:.
To give you an example of total hours and minutes:
Dim startTime As DateTime = DateTime.Now 'read from excel instead
Dim endTime As DateTime = DateTime.Now.AddDays(1.5).AddMinutes(60) 'read from excel
Dim span As TimeSpan
span = endTime.Subtract(startTime)
MessageBox.Show("Total Hours: " & (span.Days * 24) + span.Hours & ", Total Mins: " & span.Minutes)
I hope this will be able to assist in your calculation (grabbing a start and end date string, converting it to DateTime, then outputting the hours and minutes):
'This code is for when you start the job.
'which this is only hours and minutes prob should be
'Date and Time
Dim StartTime As String = DateTime.Now.ToString("h\:mm")
'This code is for when you end a Job.
'Again its only hours and minutes but prob should be
'Date and Time
Dim EndTime As String = DateTime.Now.AddHours(3.5).ToString("h\:mm")
'This is the Total Time I am going to have
'I used TimeSpan
Dim TotalTime As TimeSpan
'Once Both cells have the start and end Times I get them both with this code.
'Again this should prob be Date and Time.
Dim time1 = DateTime.Parse(StartTime)
Dim time2 = DateTime.Parse(EndTime)
'I then use this code to do my math.
TotalTime = time2 - time1
Dim Hours = TotalTime.Hours
Dim Minutes = TotalTime.Minutes
System.Console.WriteLine(Hours & "h " & Minutes & "m")
I have a userform that requires the user to input a specific date and time through two separate comboboxes, cboStartDate, cboStartTime. The user will also have to input the duration in a text field, txtDuration.
Upon saving, the start date and time will be stored in a formatted cell [DD/MM/YYYY HH:MM AM/PM]. The end date and time will be calculated from the duration field and stored in another cell with the same formatting. Something like this:
+-----------------------+-----------------------+
| startTime | endTime |
+-----------------------+-----------------------+
| 2/4/2012 11:30:00 AM | 2/4/2012 2:00:00 PM |
+-----------------------+-----------------------+
However, after running the userform through, the start time is not stored, and the end time is not calculated. Something like this:
+-----------------------+-----------------------+
| startTime | endTime |
+-----------------------+-----------------------+
| 2/4/2012 12:00:00 AM | 2/4/2012 12:00:00 AM |
+-----------------------+-----------------------+
Below is my part of my VBA code:
Dim iRow As Long
Dim ws As Worksheet
Dim startDate As Date
Dim unFmtStartDuration() As String
Dim startDuration As Double
Dim minTest As Integer
Dim endDate As Date
Dim endDuration As Double
Set ws = Worksheets("EVENTS")
'Search for the last row in the worksheet
iRow = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Date manipulation and set start and end timings
unFmtStartDuration() = Split(cboStartTime.Text, ":")
startDuration = unFmtStartDuration(0)
If unFmtStartDuration(1) = "00" Then
minTest = 0
Else
minTest = unFmtStartDuration(1)
If minTest = 30 Then
startDuration = startDuration + 0.5
End If
End If
startDate = DateValue(DateAdd("h", startDuration, cboDate.Text & " 12:00AM"))
ws.Cells(iRow, 4).Value = startDate
endDuration = txtDuration.Value
endDate = DateValue(DateAdd("h", endDuration, startDate))
ws.Cells(iRow, 5).Value = endDate
So how can I get this part sorted out? Would appreciate any help here. Thanks.
P.S. Would like to post screenshots here, but my reputation here is too low for it. Sorry.
It looks like you are only adding the time when minTest = 30, but this value probably varies quite a bit. Also, in one instance, you are comparing a string, and another a number when referencing unFmtStartDuration, which may work, but is confusing when reading your code.
To follow your current method, use
startDuration = Val(unFmtStartDuration(0) + Round(Val(unFmtStartDuration(1)) / 60, 2)
to replace this
startDuration = unFmtStartDuration(0)
If unFmtStartDuration(1) = "00" Then
minTest = 0
Else
minTest = unFmtStartDuration(1)
If minTest = 30 Then
startDuration = startDuration + 0.5
End If
End If
This will take whatever the time is and convert it to the decimal form you are using, instead of relying on the 30 match. (Unless you need that specifically. If so, say so, as I think this can still be arranged with rounding tricks.)
However, I think a better option would be to use
startDuration = TimeValue(cboStartTime.Text) * 24
So no other math or checks are involved.
Also, unless cboStartTime.Text (and subsequently startDuration) is greater than 24 hours, this
startDate = DateValue(DateAdd("h", startDuration, cboDate.Text & " 12:00AM"))
will always return the date specified in cboDate.Text with an implied 12:00:00 AM. To correct this, you will want to change to
startDate = DateAdd("h", startDuration, cboDate.Text & " 12:00AM")
I think there is some more to fix, but hopefully this gets you going in the right direction...