I need the same formula that Microsoft Project has for duration. Need to make this in Excel and SharePoint tasks.
So the column should compare two dates and look like the follow:
1 wk
2 wks
3 days
1 day
1 mth
2 mths
Doing this with a formula is not something I'm willing to tackle, perhaps someone else feels like dealing with the endless mess of nested ifs.
Instead, though, a VBA routine that will spit out the number years, months, weeks, and days between two dates should suffice.
Function projectDuration(fromdate As Date, todate As Date) As String
'years
years = DateDiff("yyyy", fromdate, todate)
If years > 1 Then
projectDuration = years & " yrs "
ElseIf years = 1 Then
projectDuration = years & " yr "
End If
'months
months = DateDiff("m", DateAdd("yyyy", years, fromdate), todate)
If months > 1 Then
projectDuration = projectDuration & months & " mths "
ElseIf months = 1 Then
projectDuration = projectDuration & months & " mth "
End If
'weeks
weeks = DateDiff("w", DateAdd("m", months, DateAdd("yyyy", years, fromdate)), todate)
If weeks > 1 Then
projectDuration = projectDuration & weeks & " wks "
ElseIf weeks = 1 Then
projectDuration = projectDuration & weeks & " wk "
End If
'days
days = DateDiff("w", DateAdd("w", weeks, DateAdd("m", months, DateAdd("yyyy", years, fromdate))), todate)
If days > 1 Then
projectDuration = projectDuration & days & " days"
ElseIf days = 1 Then
projectDuration = projectDuration & days & " day"
End If
End Function
This is a UDF. Just stick it in a new module in your VBE and then you can use this formula on your worksheet. For instance, if you have the following in your sheet:
+---+----------+-----------+
| | A | B |
+---+----------+-----------+
| 1 | 1/1/2016 | 2/16/2016 |
| 2 | | |
+---+----------+-----------+
You can use formula:
=projectDuration(A1,B1)
And it will spit out 1 mth 2 wks 1 day.
Related
This question already has answers here:
I use OR to form a multiple condition IF ELSE statement on VBA, it's not working
(2 answers)
How to use OR in if statement in VBA [duplicate]
(1 answer)
Closed 1 year ago.
I'm new to VBA and trying to write something that will fill in a column with the appropriate dates for the first of the month date entered in cell D3. Ex. If 5/1/2021 is entered in D3, the dates 5/1/2021 - 5/31/2021 will be outputted into the B column starting from row 5. For some reason, even though the month of the entered date is correctly read (for ex. 5 from 5/1/2021) I get the wrong days back. For 5/1/2021 I get 30 days. This is despite the fact that 5 is not equal to any of the numbers in the if statement for the months with 30 days. It seems whichever statement is first in line is completed. When I was using simple Ifs instead of If/Else statements, the whole thing ran despite the logical statement being False in certain cases. I don't know much about this language so I'm hoping it's a simple syntax fix. Why is this happening and how can I fix it so that the logical statements are read correctly? My code is below. Thank you so much!
VBA Code:
Sub FillDays()
Dim row As Double
row = 0
Dim startdate As Date
Dim enddate As Date
startdate = Range("D3").Value
If Month(startdate) = 4 Or 6 Or 9 Or 11 Then
enddate = DateAdd("d", 29, startdate)
' 30 days
Range("B6").Select
Do Until DateAdd("d", 1, startdate) = enddate + 1
Activecell.Offset(row, 0).Value = DateAdd("d", 1, startdate)
startdate = startdate + 1
row = row + 1
Loop
ElseIf Month(startdate) = 2 Then
enddate = DateAdd("d", 27, startdate)
' 28 days
Range("B6").Select
Do Until DateAdd("d", 1, startdate) = enddate + 1
Activecell.Offset(row, 0).Value = DateAdd("d", 1, startdate)
startdate = startdate + 1
row = row + 1
Loop
ElseIf Month(startdate) = 2 And isLeapYear(Year(startdate)) = True Then
enddate = DateAdd("d", 28, startdate)
' 29 days
Range("B6").Select
Do Until DateAdd("d", 1, startdate) = enddate + 1
Activecell.Offset(row, 0).Value = DateAdd("d", 1, startdate)
startdate = startdate + 1
row = row + 1
Loop
ElseIf Month(startdate) = 1 Or 3 Or 5 Or 7 Or 8 Or 10 Or 12 Then
enddate = DateAdd("d", 30, startdate)
' 31 days
Range("B6").Select
Do Until DateAdd("d", 1, startdate) = enddate + 1
Activecell.Offset(row, 0).Value = DateAdd("d", 1, startdate)
startdate = startdate + 1
row = row + 1
Loop
End If
End Sub
Closed. This question needs details or clarity. It is not currently accepting answers.
Want to improve this question? Add details and clarify the problem by editing this post.
Closed 2 years ago.
Improve this question
I have a column indication turnaround time expressed in weeks and days as illustrated in the photo.
How can I calculate the average for such a range of cells?
If you have the new Spill Over feature in excel you can do this in a formula
=AVERAGE(NUMBERVALUE(MID(A1:A5,1,SEARCH(" ",A1)))) & " weeks " & AVERAGE(NUMBERVALUE(MID(A1:A5,SEARCH("weeks",A1)+6,SEARCH(" ",A1,SEARCH("weeks",A1)+6)-9))) & " days"
A simple array approach via Split()
This approach
[1] assigns range data in days to a 2-dim array data ,
[2] calculate the average via WorksheetFunction Average based on day values of the data array passed as argument and
[3] display results in days and|or weeks + days
Option Explicit ' declaration head of code module
Sub RangeAverage()
'[0]Get data
With Sheet1 ' ‹‹ change to your project's sheet Code(Name)
Dim lastRow As Long
lastRow = .cells(Rows.Count, "A").End(xlUp).row
Dim data
data = .Range("A1:A5").Value
End With
'[1]Assign day values to 2-dim datafield array
Dim i As Long, tmp
For i = 1 To UBound(data)
tmp = Split(data(i, 1), " ")
data(i, 1) = tmp(0) * 7 + tmp(2)
Next i
'[2]Calculate average
Dim avg As Double: avg = WorksheetFunction.Average(data)
Dim weeks As Long: weeks = avg \ 7
'[3]Display in VB Editor's immediate window
' ~> Average: 31.8 days = 4 weeks 3.8 days
Debug.Print "Average: " & vbNewLine & _
avg & " days" & " = " & _
weeks & " weeks " & avg - weeks * 7 & " days"
End Sub
Addendum //Due to #UdearBoy 's comment
Of course a user defined function might be a more practical vehicle allowing even to choose the form of average display.
Passing a boolean argument DisplayDaysOnly:= True expressly would show days only, by default you'd get a weeks and days result (default setting to False):
Function RangeAverage(rng As Range, Optional DisplayDaysOnly = False) As String
'[0]Get data
Dim data: data = rng.Value
'[1]Assign day values to 2-dim datafield array
Dim i As Long, tmp
For i = 1 To UBound(data)
tmp = Split(data(i, 1), " ")
data(i, 1) = tmp(0) * 7 + tmp(2)
Next i
'[2]Calculate average
Dim avg As Double: avg = WorksheetFunction.Average(data)
Dim weeks As Long: weeks = avg \ 7
'[3]return average following optional user argument
If DisplayDaysOnly Then ' If True: ~> Average: 31.8 days
RangeAverage = avg & " days"
Else ' Default False: ~> 4 weeks 3.8 days
RangeAverage = weeks & " weeks " & avg - weeks * 7 & " days"
End If
End Function
I broke my head to get the date difference between two Dates, but at the beginning I had constant problems, for example:
If the month was the same in both values to be compared, the result was the negative days.
Or in some cases where it should be differences of 2 months and 30 days, it managed to have results like 3 months and 1 days, how?
well an example would be the following:
date1 = "02/15/2020"
date2 = "11/16/2019"
where in the end I got
month = 3
day = 1
why?
because at the end of 11 from 2019 to 2 of 2020 there are 3 months ... and day = 1 because of 16 - 15 are 1 (?) and if the date was a "11/14/2019" you would get a: day = -1
In the end I managed to solve all my problems with the following code:
Public Function GetDiffDate(birthdate As Date, otherDate As Date) As Variant
Dim CurrentDate, Years, ThisYear, Months, ThisMonth, Days
CurrentDate = CDate(birthdate )
Years = DateDiff("yyyy", CurrentDate, otherDate ) - 1
ThisYear = DateAdd("yyyy", Years, otherDate )
Months = DateDiff("m", ThisYear, otherDate )
ThisMonth = DateAdd("m", Months, ThisYear)
Days = DateDiff("d", ThisMonth, otherDate )
Do While (Days < 0) Or (Days > 0 And Months = 12) Or (Months < 0) Or (Months = 12) Or (Years < 0)
'> Here I can deduce if the days are negative, if so, then reduce the
'> account by one month and re-draw the days of difference
If Days < 0 Then
If Months > 0 Then Months = Months - 1
ThisMonth = DateAdd("m", Months, ThisYear)
Days = DateDiff("d", ThisMonth, otherDate ) * -1
End If
If Months < 0 Then
ThisYear = DateAdd("yyyy", Years, CurrentDate)
Months = DateDiff("m", ThisYear, otherDate )
ThisMonth = DateAdd("m", Months, ThisYear)
Days = DateDiff("d", ThisMonth, otherDate )
End If
If Days > 0 And Months = 12 Then
If Years >= 0 Then Years = Years + 1
Months = 0
ThisMonth = DateAdd("m", Months, ThisYear)
End If
If Months = 12 And Days = 0 Then
Years = Years + 1
Months = 0
End If
Loop
End Function
Example
The mistakes I had were like this:
birthDate = "02/15/2019"
otherDate = "02/16/2020"
with this code i get:
Years = DateDiff ("yyyy", CurrentDate, otherDate)
ThisYear = DateAdd ("yyyy", Years, otherDate)
Months = DateDiff ("m", ThisYear, otherDate)
ThisMonth = DateAdd ("m", Months, ThisYear)
Days = DateDiff ("d", ThisMonth, otherDate)
Results:
Years = 1 Months = 3 Days = -1
but the real value should be
Years = 0, Months = 2, Days = 30
For this I implemented my while do and if conditions to adjust the result as it should be.
But my question is:
If there is another way to make this more elegant?
I appreciate it and greetings!
Ah ok got you. You can use formula for this. Let's assume Cell A1 contains 2/15/2020 and Cell B1 contains 11/16/2019
To get the day only difference: =DATEDIF(B1,A1,"md")
To get the month only difference: =DATEDIF(B1,A1,"ym")
To get the year only difference: =DATEDIF(B1,A1,"y")
So if you want it to show in one cell, you can combine them like below:
=DATEDIF(B1,A1,"md") & " day(s), "&DATEDIF(B1,A1,"ym")&" month(s), "&DATEDIF(B1,A1,"y")&" year(s)"
This will output 30 day(s), 2 month(s), 0 year(s)
I have a worksheet with records (database). In Column B is the date the record was created (dd-MMM-yyyy format). In Column C I have the time it was created (HH:MM 24hr format).
The problem I'm having, is purging the records older than 8 hours from current system time. This code works at purging previous day records for the current finance period, but it is not taking into account 24hr format and after midnight for records older than 8 hours. I have tried many different approaches to this but still unable to figure this out.
This is the code I have since the last time I tried to figure this out:
'------------------------
' Current Finance Period
'------------------------
cSheet = CStr(Format(cStartDate, "dd-MMM-yyyy")) & " - " & CStr(Format(cEndDate, "dd-MMM-yyyy")) `Set the sheet name to use (current finance period)
CreateSheetIf (cSheet) `Create sheet if not exists
cFTarget = wbFinance.Worksheets(cSheet).UsedRange.Rows.Count `count the rows used
Set wscFinance = wbFinance.Worksheets(cSheet)
MRCForm.Caption = "MRC [ Processing... " & cSheet & " Ready to Finance records... Please wait... ]"
Me.sysMsgBox.Value = " Purging records, between " & cSheet & ", marked Ready for Finance..."
Application.ScreenUpdating = False
If cFTarget = 1 Then
If Application.WorksheetFunction.CountA(wscFinance.UsedRange) = 0 Then cFTarget = 0
End If
Source = wsMRC.UsedRange.Rows.Count
Set xRg = wsMRC.Range("AF2:AF" & Source)
Set dRg = wsMRC.Range("B2:B" & Source) `Date column in dd-MMM-yyyy format
Set tRg = wsMRC.Range("C2:C" & Source) `Time column in HH:MM 24hr format
On Error Resume Next
For K = 1 To xRg.Count
If dRg(K).Value = "" Or tRg(K).Value = "" Or xRg(K).Value = "" Then Exit For
If Format(dRg(K).Value, "dd-MMM-yyyy") >= Format(cStartDate, "dd-MMM-yyyy") And Format(dRg(K).Value, "dd-MMM-yyyy") < CStr(Format(Now, "dd-MMM-yyyy")) Then ' If date is within current finance period then
If CStr(xRg(K).Text) = "Y" Then
xRg(K).EntireRow.Copy Destination:=wscFinance.Range("A" & cFTarget + 1)
xRg(K).EntireRow.Delete
cFTotal = cFTotal + 1
MRCForm.Caption = "MRC [ Processing... " & cSheet & " (" & cFTotal & ") Please wait... ]"
If CStr(xRg(K).Value) = "Y" Then
K = K - 1
End If
cFTarget = cFTarget + 1
End If
End If
Next
Source = wsMRC.UsedRange.Rows.Count
Set xRg = wsMRC.Range("AF2:AF" & Source)
Set dRg = wsMRC.Range("B2:B" & Source) `Date column in dd-MMM-yyyy format
Set tRg = wsMRC.Range("C2:C" & Source) `Time column in HH:MM 24hr format
On Error Resume Next
For K = 1 To xRg.Count
If dRg(K).Value = "" Or tRg(K).Value = "" Or xRg(K).Value = "" Then Exit For
If Format(dRg(K).Value, "dd-MMM-yyyy") = CStr(Format(Now, "dd-MMM-yyyy")) And Format(tRg(K).Value, "HH:MM") <= Format(Now - TimeValue("08:00"), "HH:MM") Then ' If time is greater or equal to 8 hours ago then
If CStr(xRg(K).Text) = "Y" Then
xRg(K).EntireRow.Copy Destination:=wscFinance.Range("A" & cFTarget + 1)
xRg(K).EntireRow.Delete
cFTotal = cFTotal + 1
MRCForm.Caption = "MRC [ Processing... " & cSheet & " (" & cFTotal & ") Please wait... ]"
If CStr(xRg(K).Value) = "Y" Then
K = K - 1
End If
cFTarget = cFTarget + 1
End If
End If
Next
wscFinance.Columns("A:AM").AutoFit
Application.ScreenUpdating = True
Application.ScreenUpdating = True
I know the code is not very clean, just trying to get something that will function for now, will try to clean it up at a later date. Might even look at creating Functions as reusable code is more efficient.
Mock-up:
current time 11:45 on 2018.03.06
storing log date in column A
storing log time in column B
Untested code:
Dim i as long, lr as long, y as long, a as long, b as long
lr = cells(rows.count,1).end(xlup).row
For i = lr to 2 Step -1
y = TimeValue(now())-8
If y < 0 Then
a = Date(Now())-1
b = 24 + y 'y should be a negative value
Else
a = Date(Now())
b = y
End If
If Cells(1,1)=a AND Cells(1,2)>=b Then
.Rows(i).Delete
End If
Next i
Intention of this code:
loop through each row and delete the whole row if criteria met
find what 8 hours before Now() was and store as y... with the current time/date it is 03:45 on 2018.03.06, y = 3:45
If we save the current time is 02:00 on 2018.03.06 then y = -6:00
based on y being +/-, you determine the day and time
24 hour based time for where y is negative, so you add the negative number... in the case of y = -6, 24+(-6) = 18, so 18:00 hours, and the previous date (z)
you then assess the current row based on if the date matches AND if the time is less than or equal to z and y, respectively
This should be a starting point.
I like to know if it is possible to make a vba code to find the week number of a date with these conditions:
Friday is the first day of the week
If the week consists of two months, (for example: May 27,2016 to June 2,2016), the week number will be determined by the number of days in each month. In this case, the number of days in the may part of the week is greater so the week number is equal to 5.
I tried to make a solution in a spreadsheet but I can't seem to figure out how to convert it all into vba code. If anyone has an idea to how this could be done, it is greatly appreciated.
Here is my attempt on the solution:
spreadsheet (green for input) (blue for output)
spreadsheet with formulas
here's a not so elegant solution
Option Explicit
Sub main2()
Dim cell As Range
Dim date1 As Date, date2 As Date
Dim weeks1 As Long, weeks2 As Long
With Worksheets("weeks")
For Each cell In .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
date1 = cell.Value
date2 = cell.Offset(, 1).Value
weeks1 = DateDiff("ww", date1, "01/01/1900", vbFriday)
weeks2 = DateDiff("ww", dateadd("d", -Day(date1), date1), "01/01/1900", vbFriday)
If DatePart("m", date1) <> DatePart("m", date2) Then
If DateDiff("d", date1, dateadd("d", -Day(date2), date2)) >= 3 Then
If IsDate(cell.Offset(-1)) Then
cell.Offset(, 8) = cell.Offset(-1, 8) + 1
Else
cell.Offset(, 8) = weeks2 - weeks1
End If
Else
cell.Offset(, 8) = 1
End If
Else
If IsDate(cell.Offset(-1)) Then
cell.Offset(, 8) = IIf(cell.Offset(-1, 8) > 3, 1, cell.Offset(-1, 8) + 1)
Else
cell.Offset(, 8) = weeks2 - weeks1
End If
End If
Next cell
End With
End Sub
There is probably a better algorithm, but here is a UDF that, given any date, will return the Weeknumber of that date according to your specifications (if I have understood them correctly).
You can adapt to your specific requirements as necessary
Option Explicit
Function wnMonth(DT As Date)
Dim dtFF As Date
Dim dtLF As Date
Dim lWN As Long
'First and Last Fridays of current month
dtFF = DT + 8 - Day(DT) - Weekday(DT - Day(DT) + 8 - 6)
dtLF = dtFF + 28 + 7 * (Day(dtFF + 28) < Day(dtFF + 21))
If DT >= dtFF And DT < dtLF Then
lWN = Int((DT - dtFF) / 7) + 1
If Day(dtFF) > 4 Then
lWN = lWN + 1
End If
Else
If DT < dtFF Then
If Day(dtFF) > 4 Then
lWN = 1
Else
'First Friday prior month
dtFF = DateAdd("m", -1, dtFF)
dtFF = dtFF + 8 - Day(dtFF) - Weekday(dtFF - Day(dtFF) + 8 - 6)
'Last Friday prior month
dtLF = dtFF + 28 + 7 * (Day(dtFF + 28) < Day(dtFF + 21))
'First Friday weeknumber
If Day(dtFF) > 4 Then
lWN = 2
Else
lWN = 1
End If
'Last Friday weeknumber = DT weeknumber
lWN = lWN + (dtLF - dtFF) / 7
End If
Else 'DT > dtLF
'days left in the month
If (8 - Day(dtLF + 7)) < 4 Then
lWN = 1
Else
lWN = (dtLF - dtFF) / 7 + IIf(Day(dtFF) > 4, 2, 1)
End If
End If
End If
wnMonth = lWN
End Function