Is there a way to simulate the system date? - excel

So I have a macro that I only want to run on weekdays. I created the macro that (I'm hoping) will check what day of the week it is and put that into a cell. This is what I have:
Private Sub dayCheck()
If Weekday(Now) = vbMonday Or vbTuesday Or vbWednesday Or vbThursday Or vbFriday Then
Dim BlankRow As Long
BlankRow = Range("A65536").End(xlUp).Row + 1
Cells(BlankRow, 1).Select
Selection.Value = Date
Selection.Offset(0, 1).Value = Time
Selection.Offset(0, 2).Value = WeekdayName(Weekday(Now))
Selection.Offset(0, 3).Value = Environ("Username")
ElseIf Weekday(Now) = vbSaturday Or vbSunday Then
Dim time1, time2
Do
time1 = Weekday(Now)
time2 = vbMonday
Do Until time1 = time2
DoEvents
time1 = Now()
Loop
Loop
End If
Application.OnTime TimeValue("12:00:00"), "dayCheck"
End Sub
My problem is I don't have administrator rights to change the system date. Is there a way I can simulate this through a macro?

You can simulate the date code by formatting the general or number output of the now() function in excel and just add 1 to increment the date. Numbers to the right of the decimal represent the percent of time beyond midnight until the next day.
Today's datetime code is: 43412.37786
Tomorrow is 43413.37786
So your question about testing your code can be answered by creating a for loop with:
Dim Today
Today = Now
For Days = Today To Today + 7 'Tests today through next Thursday.
If Weekday(Days) = ...
Next Days
But Darren's answer looks like it solves your problem, so I'd probably just go with that.

Now gives the date/time, Date gives just the date.
Weekday(Date) returns the current day number of the week with Sunday being 1.
As it's Thursday today Weekday(Now)=vbMonday will return False.
Weekday(Now) = vbMonday Or vbTuesday Or vbWednesday Or vbThursday Or vbFriday returns 7 - I'm not sure why, but it does. The main thing here is it doesn't return TRUE or FALSE.
For that statement to work you'd have to use
Weekday(Now) = vbMonday Or Weekday(Now) = vbTuesday Or Weekday(Now) = vbWednesday Or Weekday(Now) = vbThursday Or Weekday(Now) = vbFriday.
An easier way is Weekday(Date,vbMonday)<=5 - vbMonday numbers the week Monday = 1, Sunday = 7 and it answers the question "Is date a weekday?".
Here's the code:
Sub Test()
'DayCheck Now
'Or
'DayCheck #11/7/2018 6:55:00 PM#
'Or look at next 7 days starting now.
Dim x As Long
Dim StartDate As Date
StartDate = Now
For x = 0 To 6
DayCheck StartDate + x
Next x
End Sub
Sub DayCheck(MyDate As Date)
Dim rLastCell As Range
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets("Sheet1")
If Weekday(MyDate, vbMonday) <= 5 Then
Set rLastCell = wrkSht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'Reference to the blank cell itself.
rLastCell.Resize(, 4) = Array(MyDate, MyDate, MyDate, Environ("Username"))
rLastCell.NumberFormat = "dd-mmm-yy"
rLastCell.Offset(, 1).NumberFormat = "hh:mm AM/PM"
rLastCell.Offset(, 2).NumberFormat = "dddd"
Else 'No need to check if it's a weekend - we know it's not a weekday.
'Just keep running until time1 = 2 and time2 = 2?
'I guess that'll be Midnight on Monday?
End If
End Sub
Note I'm putting the same value in columns A:C - just the date and time.
I then format each cell to show the part of the date & time you're interested in.

Related

Calculate Last Working Day of the Previous Month

Hi All can you please help me with a VBA code for Last Working Day, which excludes the weekends only, of the Previous Month?
The one I tried below is giving me only the Last date without the working day.
Range("B8") = Application.WorksheetFunction.EoMonth(Now, -1)
How about:
Sub marine()
Dim dt As Date, dt_LastMonth As Date, dt_LastWorkingDate_LastMonth As Date
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
dt = Now
dt_LastMonth = DateSerial(Year(dt), Month(dt) - 1, 1)
dt_LastWorkingDate_LastMonth = wf.WorkDay(wf.EoMonth(dt_LastMonth, 0) + 1, -1)
MsgBox dt_LastWorkingDate_LastMonth
End Sub
If today is a day in May 2021, the code produces:
Here is a simple function to return the last workday of the previous month.
Private Function LastWorkday() As Date
Dim Fun As Date ' function return value
Fun = DateSerial(Year(Date), Month(Date), 0)
Do
If (Weekday(Fun) < vbSaturday) And _
(Weekday(Fun) > vbSunday) Then Exit Do
Fun = Fun - 1
Loop
LastWorkday = Fun
Debug.Print Format(Fun, "ddd, d mmm yyyy")
End Function

VBA Formula to calculate Hours Worked

I'm still getting the hang of more complex formulas in VBA.
I'm wanting to create a system that can calculate the worked hours for a certain projects. For example, say my shift hours are 6AM-330PM. I start a project at 7AM on 11/14 and end it at 9AM on 11/16.
How would I go about making calculations so that the returned value will be the hours I worked while on the clock, and not a rolling 24-hour calculation? (While also skipping weekends if possible?)
Thanks!! Heres the code that Im trying to use....
Public Function NetWorkHours(dteStart As Date, dteEnd As Date) As Integer
Dim StDate As Date
Dim StDateD As Date
Dim StDateT As Date
Dim EnDate As Date
Dim EnDateD As Date
Dim EnDateT As Date
Dim WorkDay1Start As Date
Dim WorkDay1end As Date
Dim WorkDay2Start As Date
Dim WorkDay2end As Date
Dim Result As Integer
Dim MinDay As Integer
StDate = CDate(dteStart)
EnDate = CDate(dteEnd)
WorkDay1Start = DateValue(StDate) + TimeValue("08:00:00")
WorkDay1end = DateValue(StDate) + TimeValue("17:00:00")
WorkDay2Start = DateValue(EnDate) + TimeValue("08:00:00")
WorkDay2end = DateValue(EnDate) + TimeValue("17:00:00")
If (StDate > WorkDay1end) Then
StDate = DateAdd("d", 1, WorkDay1Start)
End If
If (StDate < WorkDay1Start) Then
StDate = WorkDay1Start
End If
If (EnDate > WorkDay2end) Then
EnDate = DateAdd("d", 1, WorkDay2Start)
End If
If (EnDate < WorkDay2Start) Then
EnDate = WorkDay2Start
End If
StDateD = CDate(Format(StDate, "Short Date"))
EnDateD = CDate(Format(EnDate, "Short Date"))
If StDateD = EnDateD Then
Result = DateDiff("n", StDate, EnDate, vbUseSystemDayOfWeek)
Else
MinDay = (8 * 60) 'Number of minutes of a working day. Change this if you change the start and end times.
'Extract the time from the two timestamps
StDateT = Format(StDate, "Short Time")
EnDateT = Format(EnDate, "Short Time")
'
'Calculate the minutes of the first day and the second one. Don't know what to do yet if the start is after 5pm or the end is before 8am
Result = DateDiff("n", StDateT, TimeValue("17:00:00"), vbUseSystemDayOfWeek)
Result = Result + DateDiff("n", TimeValue("08:00:00"), EnDateT, vbUseSystemDayOfWeek)
'Check if there was a break on both days or not.
If DateDiff("n", StDateT, TimeValue("17:00:00"), vbUseSystemDayOfWeek) > (5 * 60) Then
Result = Result - 60
End If
If DateDiff("n", TimeValue("08:00:00"), EnDateT, vbUseSystemDayOfWeek) > (5 * 60) Then
Result = Result - 60
End If
'Add 1 day to start date. This is to start the loop to get all the days between both dates.
StDateD = DateAdd("d", 1, StDateD)
Do Until StDateD = EnDateD
'If the date is not a saterday or a sunday we add one day.
If (Weekday(StDateD) > 1) And (Weekday(StDateD) < 7) Then
Result = Result + MinDay
'Check for the holiday. If the date is a holiday, then we remove one day
If Not IsNull(DLookup("[HolDate]", "Holidays", "[HolDate] = #" & Int(StDateD) & "#")) Then
Result = Result - MinDay
End If
End If
StDateD = DateAdd("d", 1, StDateD)
Loop
End If
NetWorkHours = Result
End Function
You can use DateDiff to calculate the difference between dates (and times). The following should get you pretty close to what you want to do:
Dim datStart As Date
Dim datEnd As Date
Dim sngShiftStart As Single
Dim sngShiftEnd As Single
Dim sngShiftDuration As Single
Dim lngMinutesWorked As Long
Dim lngOfftime As Long
Dim sngHoursWorked As Single
' Calculate shift length
sngShiftStart = 6
sngShiftEnd = 15.5
sngShiftDuration = sngShiftEnd - sngShiftStart
' Set start and end times
datStart = CDate("11/07/19 7:00")
datEnd = CDate("11/09/19 8:30")
lngMinutesWorked = DateDiff("n", datStart, datEnd)
lngOfftime = ((24 - sngShiftDuration) * 60) * (DateDiff("d", datStart, datEnd))
sngHoursWorked = (lngMinutesWorked - lngOfftime) / 60
MsgBox sngHoursWorked
This does not take into account weekends but you should be able to easily add that. You can check, using the Weekday function, if the Weekday of the Start date is smaller than the End date. In that case, subtract 2 * sngShiftDuration from sngHoursWorked. If your project lasts more than a week, you can look for that and subtract more weekends:
' Remove weekends
Dim sngWeekendHours As Single
If Weekday(datStart) > Weekday(datEnd) Then
' Weekend included
sngWeekendHours = (2 * sngShiftDuration) * (DateDiff("w", datStart, datEnd) + 1)
End If
sngHoursWorked = ((lngMinutesWorked - lngOfftime) / 60) - sngWeekendHours

Trying to obtain the difference between 2 dates (3 different cells)

Could you please help me to obtain the difference between 2 dates (working hours only, that's very important)
Take a look at this image:
First response is calculated by the difference between: Date First Response and Date of the problem
Elapsed time is calculated by the difference between: Date Last Response and Date of the problem
This is my macro so far (it is not working properly):
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Const WORKING_DAY_START As String = "09:00"
Const WORKING_DAY_END As String = "18:00"
Const FORMULA_WORKING_TIME As String = _
"=(INT(E2-D2)*(""" & WORKING_DAY_END & """-""" & WORKING_DAY_START & """)" & _
"+MEDIAN(MOD(E2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """)" & _
"-MEDIAN(MOD(D2,1),""" & WORKING_DAY_END & """,""" & WORKING_DAY_START & """))"
Const FORMULA_ELAPSED_TIME As String = "=F2-D2"
Dim lastrow As Long
On Error GoTo ws_bdc_exit
Application.ScreenUpdating = False
Application.EnableEvents = False
With Me
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
'input Elapsed Time
.Range("H2").Resize(lastrow - 1).Formula = FORMULA_ELAPSED_TIME
'input First Response time
.Range("G2").Resize(lastrow - 1).Formula = FORMULA_WORKING_TIME
With .Range("G2:H2").Resize(lastrow - 1)
.Value = .Value
.NumberFormat = "##0.00"
End With
End With
ws_bdc_exit:
Target.Offset(1).Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
EDIT #1: I should obtain working hours from Monday to Friday (weekend not included, but i dont know how to do it)
EDIT #2: The difference should be displayed in hours
EDIT #3: Before, i was using this macro (everything was working fine BUT i was not getting the working hours)
Public cVal
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim LastRow
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
t1 = TimeValue(CStr(Cells(i, "D").Value))
t2 = TimeValue(CStr(Cells(i, "E").Value))
t3 = TimeValue(CStr(Cells(i, "F").Value))
'input First Response time
If Hour(t2) - Hour(t1) = 0 Then
Cells(i, "G").Value = Round((Minute(t2) - Minute(t1)) / 60, 2)
Else
Cells(i, "G").Value = Hour(t2) - Hour(t1) + Round((Minute(t2) - Minute(t1)) / 60, 2)
End If
'input Elapsed Time
If Hour(t3) - Hour(t1) = 0 Then
Cells(i, "H").Value = Round((Minute(t3) - Minute(t1)) / 60, 2) '- Cells(i, "J").Value - Cells(i, "J").Value
Else
Cells(i, "H").Value = Hour(t3) - Hour(t1) + Round((Minute(t3) - Minute(t1)) / 60, 2) '- Cells(i, "J").Value
End If
Next i
Target.Offset(1).Select
End Sub
I wrote a function which should calculate the working hours, Mon-Fri, only.
Note that in your posted example, some of the dates are on Sat/Sun, so will calculate as zero.
The algorithm:
Calculate workhours for each day that is Mon-Fri as being WORKING_DAY_START -WORKING_DAY_END` hours.
Make an adjustment if the day happens to be the first or last day being calculated.
You can use this function either on the worksheet itself, you can call if from a Macro that fills in the cells with just the value.
Below I will show your original data, plus some extra lines altering your weekend work dates.
Option Explicit
Function elapsedWorkTime(startDT As Date, endDt As Date) As Date
Const WORKING_DAY_START As Date = #9:00:00 AM#
Const WORKING_DAY_END As Date = #6:00:00 PM#
Dim adjTimeStart As Date, adjTimeEnd As Date, totTime As Date
Dim D As Date
For D = DateValue(startDT) To DateValue(endDt)
Select Case Weekday(D)
Case 2 To 6
'Adj for first and last days
If D = DateValue(startDT) Then
If TimeValue(startDT) <= WORKING_DAY_START Then
adjTimeStart = 0
ElseIf TimeValue(startDT) >= WORKING_DAY_END Then
adjTimeStart = WORKING_DAY_START - WORKING_DAY_END
Else
adjTimeStart = WORKING_DAY_START - TimeValue(startDT)
End If
End If
If D = DateValue(endDt) Then
If TimeValue(endDt) >= WORKING_DAY_END Then
adjTimeEnd = 0
ElseIf TimeValue(endDt) <= WORKING_DAY_START Then
adjTimeEnd = WORKING_DAY_START - WORKING_DAY_END
Else
adjTimeEnd = TimeValue(endDt) - WORKING_DAY_END
End If
End If
totTime = totTime + WORKING_DAY_END - WORKING_DAY_START
End Select
Next D
elapsedWorkTime = totTime + adjTimeStart + adjTimeEnd
End Function
EDIT Corrected formatting on screenshot
Note that the formula in the worksheet cell, since you want the output expressed as hours, is something like:
=elapsedWorkTime(C2;D2)*24
Note the discrepancy for 5541. In your example, you show a value of 8,52 for elapsed time. But in your requirements statement you write you want to include working hours only. Working hours end at 18:00 so time spent after that should not be counted.
Maybe there is no need to use VBA.
Use NETWORKDAYS function to count workdays between dates.
Multiply them by working hours a day
Substract work hours from begin and end date (e.g. work started later than workday begins and so on)
Calculate totals.
I'd recommend to do every step in a single cell, in order to check step-by-step logics.

Need to count the number of a specific day between two dates IE number of Fridays from the begining of the current month to now() in excel vba

I would like a textbox, "txtWeek," to show the number of Fridays or Thursdays between the beginning of the month to the current date, IE I have started with
Dim MyDate, MyStr
MyDate = Format(Now, "M/d/yy")
Me.txtDate.Value = MyDate
Dim Day As Variant
ReDim Day(2)
Day = Array("Thursday", "Friday")
ComboBox1.ColumnCount = 1
ComboBox1.List() = Day
Dim X, AsDate
X = Format(Now, "M/1/yy")
If Me.ComboBox1.Text = "Friday" Then
Me.txtWeek.Value = Int((Weekday(X - 6) - X + Me.txtDate.Value) / 7)
Else
End If
End Sub
Requirements:
To show in Textbox txtDate the date of the machine
To calculate the number of Fridays or Thursdays in the month of txtDate till the date of the machine
To show in Textbox txtWeek the number of Fridays or Thursdays as per prior point
Assumptions:
The Sheet1 of the workbook containing the procedures has two TextBoxes and one ComboBox
The Procedures will be triggered by the change events of the ComboBox, when user select the weekday to count
Copy this procedure in the Code Module of Sheet1 - Change Event for the ComboBox
Private Sub CmbBox1_Change()
Dim sWkDy As String
Dim dDte1 As Date
Dim bDayC As Byte
Dim bThu As Boolean, bFri As Boolean
Rem Set Weekday
sWkDy = Me.CmbBox1.Value
Select Case sWkDy
Case "Thursday": bThu = True
Case "Friday": bFri = True
Case Else: Exit Sub
End Select
Rem Set First date of the current month
dDte1 = 1 + WorksheetFunction.EoMonth(Date, -1)
Rem Counts the weekdays
bDayC = Dte_Days_Count_To_Today(dDte1, blThu:=bThu, blFri:=bFri)
Rem Set Current Date in `txtDate`
'Using format `mmm-dd-yyyy` to ease reading of the date independently of the format (American or International)
Me.TxtDate.Value = Format(Date, "mmm-dd-yyyy") 'change as required
Rem Set count of weekdays `txtWeek`
'Using this format to directly show the weekdays counted
Me.TxtWeek.Value = "Count of " & sWkDy & "s: " & bDayC 'change as required
End Sub
Copy these procedures in a standard module
'Ensure these Keywords are at the top of the module
Option Explicit
Option Base 1
This procedure sets the available options in the Combobox – Run this first, need to run only once
Private Sub CmbBox1_Set()
Dim aWkDys As Variant
aWkDys = [{"Thursday", "Friday"}]
With Me.CmbBox1
.ColumnCount = 1
.List() = aWkDys
End With
End Sub
This Function counts the numbers of days from the date entered as input date dDteInp to the actual date of the machine TODAY. The results are generated using arithmetic calculus and avoids the loop trough each of the dates in the range. It also gives the option to count various weekdays at once e.g.: to count Thursdays and Fridays from a given date till today call it this way Call Dte_Days_Count_To_Today(dDteInp, blThu:=True, blFri:=True)
Public Function Dte_Days_Count_To_Today(dDteInp As Date, _
Optional blSun As Boolean, Optional blMon As Boolean, _
Optional blTue As Boolean, Optional blWed As Boolean, _
Optional blThu As Boolean, Optional blFri As Boolean, _
Optional blSat As Boolean)
Dim aDaysT As Variant, bDayT As Byte 'Days Target
Dim bDayI As Byte 'Day Ini
Dim iWeeks As Integer 'Weeks Period
Dim bDaysR As Byte 'Days Remaining
Dim bDaysA As Byte 'Days Additional
Dim aDaysC(7) As Integer 'Days count
Rem Set Days Base
aDaysT = Array(blSun, blMon, blTue, blWed, blThu, blFri, blSat)
bDayI = Weekday(dDteInp, vbSunday)
iWeeks = Int((Date - dDteInp + 1) / 7)
bDaysR = (Date - dDteInp + 1) Mod 7
Rem Set Day Target Count
For bDayT = 1 To 7
bDaysA = 0
aDaysC(bDayT) = 0
If aDaysT(bDayT) Then
If bDaysR = 0 Then
bDaysA = 0
ElseIf bDayI = bDayT Then
bDaysA = 1
ElseIf bDayI < bDayT Then
If bDayI + bDaysR - 1 >= bDayT Then bDaysA = 1
Else
If bDayI + bDaysR - 8 >= bDayT Then bDaysA = 1
End If
Rem Target Day Total
aDaysC(bDayT) = iWeeks + bDaysA
End If: Next
Rem Set Results - Total Days
Dte_Days_Count_To_Today = WorksheetFunction.Sum(aDaysC)
End Function
Suggest to read the following pages to gain a deeper understanding of the resources used:
Option keyword,
Variables & Constants,
Data Type Summary,
Optional keyword,
Function Statement,
For...Next Statement,
If...Then...Else Statement,
Control and Dialog Box Events,
Select Case Statement,
WorksheetFunction Object (Excel)
This UDF will count the number of whatever day you pass into it, between two dates passed as longs.
Public Function HowManyDays(Sdate As Long, Edate As Long, Wday As Long)
Dim i
Dim MyCount As Long
For i = Sdate To Edate
If Weekday(i) = Wday Then MyCount = MyCount + 1
Next i
HowManyDays = MyCount
End Function
Wday represents the day of the week, eg. sunday=1, monday=2... etc.
I don't know if it changes to monday=1, tuesday=2 etc. on other systems, or if it's always sunday=1.
With this UserForm code, a textbox will show the number of anyday depending on the value in a combobox:
Private Sub CommandButton1_Click()
Dim Sdate As Long, Edate As Long, Wday As Long
Sdate = CLng(DateSerial(Format(Now, "yy"), Format(Now, "mm"), 1))
Edate = CLng(Now)
Select Case ComboBox1.Value
Case "Sunday"
Wday = 1
Case "Monday"
Wday = 2
Case "Tuesday"
Wday = 3
Case "Wednesday"
Wday = 4
Case "Thursday"
Wday = 5
Case "Friday"
Wday = 6
Case "Saturday"
Wday = 7
End Select
TextBox1.Value = HowManyDays(Sdate, Edate, Wday)
End Sub
Private Sub UserForm_Initialize()
Dim Day As Variant
ReDim Day(7)
Day = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
ComboBox1.ColumnCount = 1
ComboBox1.List() = Day
End Sub
The start date is currently set to the first of the current month.
If you don't want to click a button to perform the action you can take the code from the CommandButton1_Click() and put it in ComboBox1_Change(), that way it will update the textbox whenever the combobox changes.

How can I compare two dates in Excel VBA?

I'm working on a school project to compare if date1 is equal to date2 - 1 (date1 is one day earlier than date2).
date2 is located one cell below date1. This is will be placed in an if/else statement where the comparison will return a Boolean.
This is the code that I am working on,
Sub someLoop()
Dim night As Long
night = 1
Dim c As Long
Dim max_rows As Long
max_rows = UsedRange.Rows.Count
For c = 2 To max_rows
Range("A" & c).Select
If ActiveCell.Value = ActiveCell.Offset(1, 0).Value2 - 1 Then
night = night + 1
Else
ActiveCell.Offset(0, 2).SetValue = night
night = 1
End If
Next c
End Sub
Dates in Excel can be treated just like numbers.
So, if [A1] has 28-May-14 and [A2] has 29-May-14, then you can just write the formula: =(A1=A2-1)
I would use DATEDIFF.
For example:
dateDiff("d", date2 , date1) = 1
With date2 = 28.05.2014 and date1 = 29.05.2014. d defines that you want the difference by days.

Resources