I have written some code which I then use in a message box to take the current date/time and i then choose how many days/hours/min to add to current date and time and it pops up.
If i only chose day as 1 extra it works perfect but the moment i chose 1 day and 1 hour then it adds 2 days to the date. If i say 1 day, 1 hour and 1 min then it adds 3 days to current date/time.
Here is my function code
Function HoursLost()
Dim Day As Date
Dim Hour As Date
Dim Minute As Date
Dim LValue As Date
LValue = Now
Day = InputBox("Enter Day ", "Enter Number of Days")
Hour = InputBox("Enter Hour", "Enter Number of Hours")
Minute = InputBox("Enter Minute", "Enter Number of Minutes")
HoursLost = Now + Day + Hour + Minute
End Function
And here is my code to call the box
Option Explicit
Sub ShowDateSelection(control As IRibbonControl)
Dim strMsg As String, strTitle As String
Application.Calculate
strMsg = HoursLost()
strTitle = "The Future Date/Time Will Be:"
MsgBox strMsg, vbOKOnly, strTitle
End Sub
Any advise on how to get around this? PS - I use this in a custom ribbon hence the ribbon part.
One way to go about this is with the DateAdd function. Replace the following:
HoursLost = Now + Day + Hour + Minute
with something like this:
HoursLost = DateAdd("d", Day, Now)
HoursLost = DateAdd("h", Hour, HoursLost)
HoursLost = DateAdd("n", Minute, HoursLost)
Related
I was looking for an answer however I failed.
I wrote following code that basically adds a new row to the table and adds a current week number in 1st cell of new row:
Set table = Workbooks("EMEA Day 2 Chasing Audit Master Report.xlsm").Worksheets("Team Stats").ListObjects.Item("TableLilla")
Set oLastrowStats = Workbooks("EMEA Day 2 Chasing Audit Master Report.xlsm").Worksheets("Team Stats").ListObjects("TableLilla").ListRows.Add
Worksheets("Team Stats").ListObjects("TableLilla").ListColumns(1).DataBodyRange(oLastrowStats.Index, 1).Value = "W" & WorksheetFunction.WeekNum(Now, vbMonday)
The weird part starts here: the code works as it should on 2 computers but it does not on third one. On the 3rd computer, new row is added but the 3rd code line doesn't insert a week number.
I'm pretty sure it is related with this particular notebook, however have no clue where to look for solution. I didn't notice any major differences in Excel Settings. I've also checked the Win10 regional and date set up and they are the same as on my notebook.
Do you have any clue how to sort this out?
Thanks!
Try using a function that returns the ISO 8601 week number (and year):
' Constants.
Public Const MaxWeekValue As Integer = 53
Public Const MinWeekValue As Integer = 1
Public Const MaxMonthValue As Integer = 12
Public Const MinMonthValue As Integer = 1
' Returns the ISO 8601 week of a date.
' The related ISO year is returned by ref.
'
' 2016-01-06. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function Week( _
ByVal Date1 As Date, _
Optional ByRef IsoYear As Integer) _
As Integer
Dim Month As Integer
Dim Interval As String
Dim Result As Integer
Interval = "ww"
Month = VBA.Month(Date1)
' Initially, set the ISO year to the calendar year.
IsoYear = VBA.Year(Date1)
Result = DatePart(Interval, Date1, vbMonday, vbFirstFourDays)
If Result = MaxWeekValue Then
If DatePart(Interval, DateAdd(Interval, 1, Date1), vbMonday, vbFirstFourDays) = MinWeekValue Then
' OK. The next week is the first week of the following year.
Else
' This is really the first week of the next ISO year.
' Correct for DatePart bug.
Result = MinWeekValue
End If
End If
' Adjust year where week number belongs to next or previous year.
If Month = MinMonthValue Then
If Result >= MaxWeekValue - 1 Then
' This is an early date of January belonging to the last week of the previous ISO year.
IsoYear = IsoYear - 1
End If
ElseIf Month = MaxMonthValue Then
If Result = MinWeekValue Then
' This is a late date of December belonging to the first week of the next ISO year.
IsoYear = IsoYear + 1
End If
End If
' IsoYear is returned by reference.
Week = Result
End Function
Like this:
Worksheets("Team Stats").ListObjects("TableLilla").ListColumns(1).DataBodyRange(oLastrowStats.Index, 1).Value = "W" & Week(Date)
For example: users of my userform will enter a start time and end time in HH:MM AM/PM format. I need to subtract the start time entered from 10:00 a.m and determine if there is greater than 3 hours in that time frame? Obviously, my coding below isn't correct as it is subtracting Arrival Time instead of a set time of 10:00 a.m.. Also, I know something isn't correct with my 'If' statement but I'm not sure what? I have tried searching several different venues for what my errors might be but am having no luck.
Function TimeDiff(txtDepartTime, txtArrivalTime)
TimeDiff = Abs(txtDepartTime - txtArrivalTime)
If TimeDiff >= 3 Then "True","False"
End If
Option Explicit
Sub test()
Dim userEnteredValue As String
Dim userEnteredDate As Date
Dim referenceDate As Date
Dim diffHours As Double
Dim isLonger As Boolean
userEnteredValue = "2:30 PM"
If Not IsDate(userEnteredValue) Then
MsgBox "Invalid time entered"
Exit Sub
End If
userEnteredDate = CDate(userEnteredValue)
If userEnteredDate > 1 Then
MsgBox "Unexpected date exists"
Exit Sub
End If
referenceDate = TimeSerial(10, 0, 0)
diffHours = (userEnteredDate - referenceDate) * 24
isLonger = diffHours >= 3
If isLonger Then
MsgBox "Time frame greater or equal 3 hours"
Else
MsgBox "Time frame less then 3 hours"
End If
End Sub
EDIT: I only want to execute the code if the new date is in the future AND the month is different.
I have two dates. I want to execute code only if the new date is in a different month from the old date, but I need to execute two different types of code:
1. If the new date's month is in the future
e.g. if new date is Jan 15, 2021 and old date is Mar 15, 2020, I want
to execute part 1.
2. A different code if the new date's month is in the past
e.g. if new date is Mar 15, 2020 and old date is Jan 15, 2021, I want
to execute part 2
I think there's a better way to do it than what I've done in the code
Dim old_date as variant
Dim new_date as variant
**'NOTE: For the intents of this code, the new_date and old_date have been previously defined by the user in a previous part of code**
If CLng(Format(new_date, "yyyymm")) <> CLng(Format(old_date, "yyyymm")) Then
If CLng(Format(new_date, "yyyymm")) > CLng(Format(old_date, "yyyymm")) Then
'Temporary msgbox for my testing purposes
MsgBox "Your new date is in a month in the future"
'Additional code to execute
Else
'Temporary msgbox for my testing purposes
MsgBox "Your new date is in a month in the past"
'Additional code to execute
End If
End If
My code works as is, but I know there's a better way to do what I did than what I did
DateDiff with a first argument of "m" will return a number equal to the difference in months. if it is positive its forward, negative is back, 0 is same.
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/datediff-function
Dim old_date as date
Dim new_date as date
dim monthdatediff as long
monthdatediff = datediff("m", old_date, new_date)
if monthdatediff = 0 then
msgbox "Same Month"
elseif monthdatediff > 0 then
msgbox "Future Month"
else
msgbox "Past Month"
end if
Ah yes, I had originally thought of if new_date>old_date but I only want to execute part 1 of the code if new_date>old_date and the month is different (e.g. If new_date>old_date & month(new_date)<>month(old_date)) – newtovba 3 mins ago
In that case, find the month and work with that as shown below.
Option Explicit
Sub Sample()
Dim old_date As Date
Dim new_date As Date
Dim oldDateMonth As Long
Dim newDateMonth As Long
'~~> Populating from B2 and B3. Change as applicable
old_date = [b2]: new_date = [b3]
'~~> Get the month
oldDateMonth = Month(old_date)
newDateMonth = Month(new_date)
If new_date > old_date Then
If oldDateMonth <> newDateMonth Then
'
' Do what you want (PART 1)
'
End If
End If
End Sub
Your code look OK. I prefer using the right type (Date here): faster and safer.
You could also slightly simplify the logic.
Dim old_date as Date
Dim new_date as Date
If new_date > old_date Then
debug.print now, "Your new date is in a month in the future"
'Additional code to execute
ElseIf new_date < old_date
debug.print "Your new date is in a month in the past"
'Additional code to execute
End If
**Hello all,
I have a question that is ½ about the code and ½ about the logic behind the code.
Background:
This is a vary small part of one Sub in a large workbook collection. The goal of this bit of code is to accept a user input for the number of business days they want to look out for a date range. Determine if the dates between contain weekend days, if so, add 2 to the range. The input is data type Integer. The number is added to the current date to get the last date in the range and assigned to dDate for use in this and other Sub’s.
What the code should do:
The most a user can request to look out for is 14 (don’t need error handling for more then 14). The request can be made any day of the week including weekends. If a request is made on Wednesday to look out 3 business days, the program should add 2 to show Thursday, Friday, Saturday, Sunday, and Monday. If the request is made on a Saturday to show 2 business days the program should add 1 to show Sunday, Monday, and Tuesday. If the number requested has 2 weekends between the range (8-14) then add 4.
So in short, for every weekend day in the date range, add one day to the user input number.
Please explain any responses with in code comments for all VBA skill levels.
Both Code and logic help is welcome.
**
'prompt to enter number of days to look out for shortage, new addition to the code added to expand usability
iNumDays = Application.InputBox(prompt:="Enter number of business days to look out for")
iweekday = Weekday(Date, vbMonday) 'get todays weekday number 1-7 with Monday being 1, Sunday being 7
'if today is Thursday or Friday the next 2 business days fall on the weekend, if so then we need to look out 2 days more
If iweekday > 3 Then 'iweekday is integer of todays weekday number, if its past Wednesday then enter If
iNumDays = iNumDays + 2 'add 2 to user input
End If
dDate = Date + iNumDays 'add user day to look out input to todays date to get last date in desired date range 'get the column header for the date we are looking out to
Solution found here: https://www.experts-exchange.com/questions/23461938/VB-net-Add-Days-to-a-Date.html
Public Function AddNBusinessDays(ByVal startDate As DateTime, ByVal numDays As Integer) As DateTime
If numDays = 0 Then Return New DateTime(startDate.Ticks)
If numDays < 0 Then Throw New ArgumentException()
Dim i As Integer
Dim totalDays As Integer
Dim businessDays As Integer
totalDays = 0
businessDays = 0
Dim currDate As DateTime
While businessDays < numDays
totalDays += 1
currDate = startDate.AddDays(totalDays)
If Not (currDate.DayOfWeek = DayOfWeek.Saturday Or currDate.DayOfWeek = DayOfWeek.Sunday) Then
businessDays += 1
End If
End While
Return currDate
End Function
The most intuitive way to do this (in my opinion) is to simply count the days forward one by one until you added as many work days as requested by the user. The 14 days limit is not necessary anyways, as it is a loop that works with any integer up to billions of days...
Sub adddays()
Dim iNumDays As Integer
Dim iWeekDay As Integer
Dim dDate As Date
'prompt to enter number of days to look out for shortage, new addition to the code added to expand usability
iNumDays = Application.InputBox(prompt:="Enter number of business days to look out for")
dDate = Date ' initialize dDate with today's date before entering the counting loop
While iNumDays > 0 ' as long as the there are still workdays left to add, repeat this
dDate = dDate + 1 ' move calendar forward by one day
iWeekDay = Weekday(dDate, vbMonday) ' check what weekday we arrived at
If iWeekDay < 6 Then ' if we're looking at a working day, we successfully added one of the desired weekdays to be added
iNumDays = iNumDays - 1
End If
Wend
MsgBox ("Target date is: " & Str(dDate)) 'check results of the calculation or replace with whatever other logic you want here
End Sub
Very new to working with Visual Basic / Excel. I am trying to write a quick script that enters the current time in one column, and allows the user to enter how many days/hours/minutes will pass until a new time, and output that in another column.
I'm sure this isn't the best way to do it, but what I have so far is the following. I have given up on fiddling with dates, and am just working with the time:
Sub TimeModule()
Dim DaysLeft, HoursLeft, MinutesLeft As Double
DaysLeft = Val(InputBox("Days left"))
HoursLeft = Val(InputBox("Hours left"))
MinutesLeft = Val(InputBox("Minutes left"))
Dim CurrentTime As Date
CurrentTime = TimeValue(Now())
ActiveCell.Value = CurrentTime
ActiveCell.Offset(0, 1) = CurrentTime + Time(HoursLeft, MinutesLeft, 0)
End Sub
I am getting an error, of course. If anyone could shed some light on a better way to do this, along with the functions I'm misusing, I would really appreciate it!
Edit: I would, of course ultimately like for the script to handle days as well.
I think this is possible just using cell functions in Excel, if I've understood you correctly.
For example, this is what you'd see...
Time Now: Days: Hours: Minutes: New Time:
30/05/2012 23:34 15 6 23 15/06/2012 05:57
...and this is what is in each cell (assuming top-left cell is A1)...
Time Now: Days: Hours: Minutes: New Time:
=NOW() 15 6 23 =A2+B2+TIME(C2,D2,0)
Describing each function:
NOW() returns the current date and time formatted as a date and time.
DATE(year,month,day) returns the number that represents the date in MS Excel date-time code.
TIME(hours,minutes,seconds) converts hours, minutes, and seconds given as numbers to an Excel serial number, formatted with a time format.
Dissecting the equation in the last cell:
A2 is the cell containing the current date/time (as of last worksheet calculation).
B2 is the user-inputted value for days.
TIME(C2,D2,0) is the TIME() function, taking the user-inputted values for hours and minutes from cells C2 and D2 respectively.
Is this anything like your intended functionality...?
If you want to use VBA the only issue with your code is the "Time" function.
You can use CDate instead :
Sub TimeModule()
Dim DaysLeft, HoursLeft, MinutesLeft As Double
DaysLeft = Val(InputBox("Days left"))
HoursLeft = Val(InputBox("Hours left"))
MinutesLeft = Val(InputBox("Minutes left"))
Dim CurrentTime As Date
CurrentTime = TimeValue(Now())
ActiveCell.Value = Now()
ActiveCell.Offset(0, 1) = ActiveCell.Value + DaysLeft + CDate(HoursLeft & ":" & MinutesLeft)
'ActiveCell.Offset(0, 1) = CurrentTime + Time(HoursLeft, MinutesLeft, 0)
End Sub
When you 'Dim' in that fashion, you have to record the data type for each variable. The way you have it MinutesLeft is a Double and everything is (by default) a Variant.
The Time function you're looking for is TimeSerial.
Dates are stored as the number of days since a certain date. To add days to a date, you can simply add the numbers together.
Sub TimeModule()
Dim lDaysLeft As Long
Dim lHoursLeft As Long
Dim lMinutesLeft As Double
Dim dtCurrent As Date
lDaysLeft = Val(InputBox("Days left"))
lHoursLeft = Val(InputBox("Hours left"))
lMinutesLeft = Val(InputBox("Minutes left"))
dtCurrent = Now()
ActiveCell.Value = dtCurrent
ActiveCell.Offset(0, 1).Value = dtCurrent + lDaysLeft + TimeSerial(lHoursLeft, lMinutesLeft, 0)
End Sub