I have some resourcing data based on estimations showing me hours per month for each "role" assigned to a task.
I need to be able to count the number of times a "month" appears in a weekly count between two dates. So i can split the hours accordingly.
i.e between 02-Oct-21 and 27-Nov-21 there is 9 weeks, output from the below code:
Public Sub dtConv()
Dim stDt, enDt As Date
stDt = Sheets("New Job Template").Range("F1").Value
enDt = Sheets("New Job Template").Range("H1").Value
Debug.Print (DateDiff("ww", stDt, enDt))
End Sub
Shows me 8 weeks (this is wrong).
But the above does not tell me that "November" occurs 5 times, "December" occurs 4 times.
Can I leverage DateDiff to also count the number of times Nov/Dec/Jan etc occurs between start/end dates?
Please, test the next code. It will return the correct number of weeks, October and November months occurrences:
Private Sub testTextEvaluateDateManyMonths()
Dim arrD, stDt As Date, enDt As Date, noD As Long, startD As Long, startM As Long, i As Long, mName As String
Dim WCount As Long, prevWNo As Long, wNo As Long, k As Long, dictM As Object
Const firstWeekDay As Long = vbMonday '(2) you should use here your first day of the week.
' for Sunday you should use vbSunday, or 1
stDt = "02-Oct-21": enDt = "28-Feb-22"
noD = enDt - stDt + 1 ' number of involved days between the two date
startM = month(stDt) ' month number in stDt
startD = Day(stDt) ' day number in stDt
'create an array of involved dates:
'arrD = Application.Transpose(Evaluate("TEXT(DATE(2021," & startM & ",row(" & startD & ":" & noD + 1 & ")),""dd.mm.yyyy"")"))
arrD = Evaluate("TEXT(DATE(2021," & startM & ",row(" & startD & ":" & noD + 1 & ")),""dd.mm.yyyy"")")
ReDim arrMonths(DateDiff("m", stDt, enDt, vbMonday))
Debug.Print Join(Application.Transpose(arrD), "|") 'just to see the date range in Immediate Window...
Set dictM = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arrD)
wNo = WorksheetFunction.WeekNum(CDate(arrD(i, 1)), firstWeekDay)
If wNo <> prevWNo Then prevWNo = wNo: WCount = WCount + 1
mName = Format(CDate(arrD(i, 1)), "mmmm")
dictM(mName) = dictM(mName) + 1
Next i
For i = 0 To dictM.Count - 1
Debug.Print "Month " & dictM.Keys()(i) & " appears " & dictM.items()(i) & " times."
Next i
Debug.Print "Weeks number: " & WCount
End Sub
The above code builds an array of the necessary days range and analyze it very fast (in memory), extracting what (I understood) you need.
firstWeekDay constant is needed. If "02-Oct-21" would be Sunday on Monday the function to return week number may return a week (ending in Sunday) in plus or in minus. For the range you need (now) it doesn't matter, but if you change the involved date, it may matter, for an accurate return...
If something not clear or other things to be extracted from the days range, please do not hesitate to ask for clarifications.
Not sure if this is what you want but see how you go and adapt it as need be. Could it be done better?!? Maybe!
Add a reference to Scripting.Dictionary in your project and put your dates in A1 (From date) and A2 (To date) respectively.
Public Sub CountMonthsInWeeks()
Dim objValues As Scripting.Dictionary
Dim dtFrom As Date, dtTo As Date, bDone As Boolean
Dim dtFromTemp As Date, dtToTemp As Date, intMonth As Integer
Dim strKey As Variant, strMonth As String
Set objValues = New Scripting.Dictionary
dtFrom = CDate(Sheet1.Range("A1").Value)
dtTo = CDate(Sheet1.Range("A2").Value) - 1
dtFromTemp = dtFrom
Do While Not bDone
dtToTemp = dtFromTemp + 6
Debug.Print "From = " & dtFromTemp & ", To = " & dtToTemp
If dtToTemp >= dtTo Then
dtToTemp = dtTo
bDone = True
End If
UpdateMonthCount objValues, Month(dtFromTemp)
If Month(dtToTemp) <> Month(dtFromTemp) Then UpdateMonthCount objValues, Month(dtToTemp)
dtFromTemp = dtToTemp + 1
Loop
Debug.Print ""
For Each strKey In objValues.Keys
strMonth = WorksheetFunction.Text(DateSerial(Year(Now), strKey, 1), "mmm")
Debug.Print "Month " & strMonth & " = " & objValues.Item(strKey)
Next
End Sub
Private Sub UpdateMonthCount(ByRef objValues As Scripting.Dictionary, ByVal intMonth As Integer)
If Not objValues.Exists(intMonth) Then objValues.Add intMonth, 0
objValues.Item(intMonth) = objValues.Item(intMonth) + 1
End Sub
I've made an assumption that the start date will always be the correct day, I'm not checking to see if it's as you described. It seems like overkill to me.
Related
I am trying to figure out how to get the the total of days in a month like for every monday to saturday or tuesday to sunday then multiply by working hours. It depends on the user if what they like to input in cell. However, the CALCULATION it depends on the date where the user input either in textbox or cell.
For X = 2 To lastRow
val = ThisWorkbook.Sheets("Input").Cells(X, 2).Value
If UCase(val) Like "*TO*" Then
Dim numStringTo As Integer
Dim strToDays() As String
Dim wordToCount As Long
numStringTo = 3
strToDays = VBA.Split(val, " ")
wordToCount = UBound(strToDays)
whEveryDay = ThisWorkbook.Sheets("Input").Cells(X, 4).Value
whEveryDay = whEveryDay * Weekday(nb_days, 6)
Debug.Print "Every = " & whEveryDay
End If
Next X
I need to get the total of days in a month and multiply by working hours. As of now we are in January 2023 and the pattern for January is 2-7,9-14,16-21,23-28,30-31 and the patter for November 2022 is 1-5,8-12,15-19,22-26,29-30.
For example:
Days
Date
Working Hours
every Monday to Saturday
2-7,9-14,16-21,23-28,30-31
1.2
every Tuesday to Saturday
1-5,8-12,15-19,22-26,29-30
0.5
Example of calculation:
Days * Working hours
And I need the calculation dynamically like for example if I change the cell of "every Monday to Saturday" to "every Wednesday to Monday" so, the count of days in a month will be also dynamically.
Thanks in advance,
James
Option Explicit
Sub demo()
Dim lastrow As Long, r As Long, s As String, dt As Date
s = InputBox("Input Date")
If IsDate(s) Then
dt = CDate(s)
Else
MsgBox s & " not a date", vbCritical
Exit Sub
End If
With ThisWorkbook.Sheets("Input")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
For r = 2 To lastrow
s = .Cells(r, "B").Value
If UCase(s) Like "*TO*" Then
' total days in column E
.Cells(r, "E") = mydatecalc(dt, s)
' hrs per day * days
.Cells(r, "F").FormulaR1C1 = "=RC[-2]*RC[-1]"
End If
Next
End With
MsgBox "Calc done for " & Format(dt, "mmm yyyy")
End Sub
Function mydatecalc(dtNow As Date, s As String) As Long
Dim m As Integer, s1 As String, s2 As String, d As String
Dim dt As Date, dtStart As Date, dtEnd As Date
Dim n As Integer, ar, bCount As Boolean, msg As String
m = Month(dtNow) ' input month
dtStart = DateSerial(Year(dtNow), m, 1)
dtEnd = DateAdd("m", 1, dtStart) - 1
ar = Split(s, " ")
s1 = Left(ar(1), 3)
s2 = Left(ar(3), 3)
For dt = dtStart To dtEnd
d = Format(dt, "ddd")
If d = s1 Then bCount = True
If bCount Then
n = n + 1
msg = msg & vbLf & n & " " & Format(dt, "ddd dd")
End If
If d = s2 Then bCount = False
Next
'MsgBox s & " = " & n & " days in " & Format(dtNow, "mmm yyyy") & msg
mydatecalc = n
End Function
You could achieve that with a formula as well (Excel 365) and the following setting:
=LET(monthDays,SEQUENCE(EDATE(A2,1)-A2,1,A2),
weekdays,FILTER(SEQUENCE(1,7),B2:H2<>""),
workingHours,I2,
workedDays,FILTER(monthDays,ISNUMBER(MATCH(WEEKDAY(monthDays,2),weekdays,0))),
COUNT(workedDays)*workingHours)
Please, test the next solution. The range to be processed starts from column B:B and the return will be done in E:E. The code assumes that all strings in B:B contain the necessary data of pattern "every 'day name' to 'day name'":
Sub getHours()
Dim ws As Worksheet, lastR As Long, arr, i As Long, curDate As Date
curDate = Date 'use here your date where from to extract the month
Set ws = ActiveSheet
lastR = ws.Range("B" & ws.rows.count).End(xlUp).Row
arr = ws.Range("B2:E" & lastR).Value2
For i = 1 To UBound(arr)
arr(i, 4) = TotalHoursPerDaysGroup(CStr(arr(i, 1)), curDate, CDbl(arr(i, 3)))
Next i
ws.Range("B2:E" & lastR).Value2 = arr
End Sub
Function TotalHoursPerDaysGroup(val As String, curDay As Date, workingH As Double) As Double
Dim curMonth As Long, startDN As String, endDN As String, nb_days As Long
Dim dtStart As Date, dtEnd As Date, dayN As String, d As Date, arrND, boolCount As Boolean
'Dim arrDaysRo: arrDaysRo = Split("lun.,mar.,mie.,joi,vin.,sâm.,dum.", ",") 'localized days name...
'Dim arrDaysEn: arrDaysEn = Split("Mon,Tue,Wen,Thu,Fry,Sat,Sun", ",")
curMonth = Month(curDay) ' current month
dtStart = DateSerial(Year(curDay), curMonth, 1)
dtEnd = WorksheetFunction.EoMonth(dtStart, 0)
arrND = Split(val, " ")
startDN = left(arrND(1), 3)
endDN = left(arrND(3), 3)
For d = dtStart To dtEnd
dayN = Format(d, "ddd")
If dayN = startDN Then boolCount = True
'If arrDaysEn(Application.match(dayN, arrDaysRo, 0) - 1) = startDN Then boolCount = True
If boolCount Then
nb_days = nb_days + 1
End If
If d = endDN Then boolCount = False
'If arrDaysEn(Application.match(dayN, arrDaysRo, 0) - 1) = endDN Then boolCount = False
Next d
TotalHoursPerDaysGroup = nb_days * workingH
End Function
I tried using first three characters of the days name, but because of localization, I couldn't, so I created two equivalence arrays to overpass the problem. I let them in the function, just in case...
If no such a problem, you can comment the lines making the equivalence and uncomment the ones above them. I can see that my solution used in the function is very similar with the one already posted...
I am trying to get all the dates for the Mondays in the current month. For example, in the current month May 2021 we would have: 3/05/2021, 10/05/2021, 17/05/2021, 24/05/2021, 31/05/2021.
On investigation I found this answer for an older question which helps to
Calculate the number of weeks in a month, however this shows 6 as an answer. Which is correct (See shared calendar). However I wish to count only the Mondays on the month.
I also have a complementary code which gives me the number of Mondays in the month:
Sub NumMondays()
Dim i As Integer
Dim num_mondays As Integer
Dim test_date As Date
Dim orig_month As Integer
month_name = Format(Date, "mmmm")
year_name = Format(Date, "yyyy")
' Get the first day of the month.
test_date = CDate(month_name & " 1, " & year_name)
' Count the Mondays.
orig_month = Month(test_date)
Do
num_mondays = num_mondays + 1
test_date = DateAdd("ww", 1, test_date)
Loop While (Month(test_date) = orig_month)
Debug.Print test_date
Debug.Print orig_month
Debug.Print num_mondays
End Sub
Such code prints 5 for number of Mondays, however I have been unable to convert this to the actual dates of such Mondays. Any suggestions?
Thanks a lot in advance
A Functional Solution
A good approach is to use a function that will return a collection of the days from a specified month.
This is similar to other approaches provided — however, this adds a bit of performance and more importantly intellisense for the day of the week.
Public Function GetMonthDays(dayToGet As VbDayOfWeek _
, monthToGetFrom As Long _
, yearToGetFrom As Long) As Collection
Set GetMonthDays = New Collection
' First Starting date, and will be used
' for incrementing to next date/next day.
Dim nextDate As Date
nextDate = DateSerial(yearToGetFrom, monthToGetFrom, 1)
' Loop until month changes to next month.
Do While month(nextDate) = monthToGetFrom
' If weekday matches, then add and
' increment to next week (7 days)
If Weekday(nextDate) = dayToGet Then
GetMonthDays.Add nextDate
nextDate = nextDate + 7
' Day did not match, therefore increment
' 1 day until it does match.
Else
nextDate = nextDate + 1
End If
Loop
End Function
Example
Here is a basic example of how to use it.
Sub testGetMonthDays()
Dim mondayDate As Variant
For Each mondayDate In GetMonthDays(vbMonday, month(Date), year(Date))
Debug.Print mondayDate
Next
End Sub
5/3/2021
5/10/2021
5/17/2021
5/24/2021
5/31/2021
Try the next code, please:
Sub NumMondays()
Dim i As Long, month_name, year_name, num_mondays As Integer
Dim test_date As Date, orig_month As Integer, arrMondays, k As Long
month_name = Format(Date, "mmmm")
year_name = Format(Date, "yyyy")
' Get the first day of the month.
test_date = CDate(month_name & " 1, " & year_name)
orig_month = month(test_date)
ReDim arrMondays(4)
'extract and count Mondays:
Do
If Weekday(test_date, vbMonday) = 1 Then
arrMondays(k) = test_date: k = k + 1: num_mondays = num_mondays + 1
End If
test_date = test_date + 1
Loop While (month(test_date) = orig_month)
ReDim Preserve arrMondays(k - 1)
Debug.Print "Current month no = " & orig_month
Debug.Print "No of Mondays = " & num_mondays
Debug.Print Join(arrMondays, ", ")
End Sub
Brute force approach
Sub tester()
Dim dt
For Each dt In GetDayDates(2021, 5, "Mon")
Debug.Print dt
Next dt
End Sub
Function GetDayDates(yr As Long, mon As Long, d As String)
Dim dt As Date, col As New Collection
dt = DateSerial(yr, mon, 1)
Do While Month(dt) = mon
If Format(dt, "ddd") = d Then col.Add dt
dt = dt + 1
Loop
Set GetDayDates = col
End Function
Different approach. There is a somewhat known Excel formula that provides the Monday of a Given Weeknumber and Year (=DATE(A2, 1, -2) - WEEKDAY(DATE(A2, 1, 3)) + B2 * 7) [A2 is the Year, B2 is the Weeknumber]. In this case I loop all weeks on a month and use that formula on each week.
Sub CaseOfTheMondays()
Dim inDate As Date, sDate As Date, eDate As Date, sYear As Date, mDate As Date
Dim cMonth As Integer, i As Integer, x As Integer
inDate = InputBox("Enter a valid date")
If IsDate(inDate) Then
ThisWorkbook.Worksheets(1).Columns("A").ClearContents
sDate = DateAdd("d", -(Format(inDate, "d") - 1), inDate)
eDate = DateAdd("m", 1, inDate) - (Format(inDate, "d") + 1)
sYear = DateAdd("m", -(Format(inDate, "m") - 1), DateAdd("d", -(Format(inDate, "d") - 1), inDate))
cMonth = Format(inDate, "m")
sWeek = WorksheetFunction.WeekNum(sDate, vbMonday)
eWeek = WorksheetFunction.WeekNum(eDate, vbMonday)
x = 1
For i = sWeek To eWeek
mDate = DateAdd("d", -3, sYear) - Weekday(DateAdd("d", 2, sYear)) + (i * 7)
If Format(mDate, "m") = cMonth Then
ThisWorkbook.Worksheets(1).Cells(x, 1).Value = mDate
x = x + 1
End If
Next i
Else
MsgBox "invalid date"
End If
End Sub
Let's suppose in A1 I have 1 (for me is month number) that is January.
How can I get the 1st day and the last day for the current year, given the month number 4? (IN VBA IF POSSIBLE)
Didn't try code because I found only formulas on the internet but nothing with month number...
Every links and suggestions are accepted aswell
One option is with DateSerial and DateAdd:
Sub Test()
Dim monthNum As Long
monthNum = 4
Dim firstDay As Date
firstDay = DateSerial(Year(Date), monthNum, 1)
Dim lastDay As Date
lastDay = DateAdd("m", 1, firstDay) - 1
End Sub
EDIT: You can also use DateSerial for the last day:
DateSerial(Year(Date), monthNumber + 1, 0)
You can try something like the below. It is definitely a workaround as I am sure someone else will have a better solution!
Option Explicit
Sub GetLastDay()
Dim i As Long
Dim lMonth As Long, dDateTest As Date
'april
lMonth = 4
'first date
Debug.Print "First day in month is always 1"
'last day
'31 is max in any given month
For i = 1 To 32
dDateTest = DateSerial(Year(Date), lMonth, i)
If Month(dDateTest) <> lMonth Then
Debug.Print "Last day in month = " & (i - 1)
Exit For
End If
Next i
End Sub
Resulting print out:
Last day in month = 30
I have a solution for you. lets assume you have the number of the months in Column A and the first date & last date of the same month number should reflect in Column B and C respectively:
Dim mnt As Long, xrow As Long
Dim i As Long, Ws As Worksheet
Set Ws = ThisWorkbook.Sheets("Sheet1")
xrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To xrow
Ws.Cells(i, 2).Value = "=date(year(today()),RC[-1],1)"
Ws.Cells(i, 3).Value = "=eomonth(RC[-1],0)"
Next i
End Sub
Hope That Helps
I have the following issue with this VBA:
Column A (FirstDate), Column B (EndDate), Column C (Number) are input:
Sub DateTest()
Dim FirstDate As Date ' Declare variables.
Dim IntervalType As String
Dim Number As Integer
Dim EndDate As Date
Dim TempDate As Date
Dim i As Integer
IntervalType = "m" ' "m" specifies MONTHS as interval.
With ActiveWorkbook.Worksheets(1)
lLastRow = .UsedRange.Rows.Count
For lRow = 1 To lLastRow
FirstDate = Format(.Cells(lRow, 1).Value, "YYYY-MM-DD")
EndDate = Format(.Cells(lRow, 2).Value, "YYYY-MM-DD")
Number = .Cells(lRow, 3).Value
' If the number is not greater than zero an infinite loop will happen.
If Number <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
i = 1
Do Until TempDate = EndDate
If i <= 1 Then
TempDate = DateAdd(IntervalType, Number, FirstDate)
Else
TempDate = DateAdd(IntervalType, Number, TempDate)
End If
i = i + 1
Debug.Print i
Loop
Cells(lRow, 4).Value = i - 1
Next
End With
End Sub
If I run the above for 9 rows I got this, the output is the highlighted column:
All good so far, but if I try to run the code for more than 9 rows:
I got this:
I have searched for the answer on here I read in some posts that I'm not "calling the function in the right way" but I don't understand what do I need to change also I read that I need to check the permitted ranges for arguments to make sure no arrangement exceeds the permitted values.
How about the following using DateDiff:
Sub DateTest()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
Dim IntervalType As String
Dim lLastRow As Long, lRow As Long
IntervalType = "m" ' "m" specifies MONTHS as interval.
lLastRow = ws.UsedRange.Rows.Count
For lRow = 1 To lLastRow
' If the number is not greater than zero an infinite loop will happen.
If ws.Cells(lRow, 3).Value <= 0 Then
MsgBox "Number needs to be greater than 0", vbCritical
Exit Sub
End If
ws.Cells(lRow, 4).Value = DateDiff(IntervalType, ws.Cells(lRow, 1).Value, ws.Cells(lRow, 2).Value) / ws.Cells(lRow, 3).Value
Next lRow
End Sub
Change Debug.Print i to Debug.Print i & " - " & TempDate and see your Immediate Window. You will notice that for row 11 (31/08/2010 - 31/08/2020) the code is shifting the day from 31st (31st of August) to 30th (30th of November) and then defaults to 28th (28th of February). Once it reaches this stage, it will always take 28th day into account, making it impossible for the loop to finish the calculation (infinite loop).
The result will look like that:
2 - 30/11/2010
3 - 28/02/2011
4 - 28/05/2011
...
39 - 28/02/2020
40 - 28/05/2020
41 - 28/08/2020
42 - 28/11/2020
...
89 - 28/08/2032
90 - 28/11/2032
91 - 28/02/2033
...
I hope it clarifies the issue well enough and it gives you a hint on how to proceed.
I have a list of start and finish dates Cols J & K this list is dynamic. I need to list the individual dates between the two dates to a row (P13) to the right hand side of each set of dates horizontally. The Exit Sub code is to stop the row updating and jump to the next row rather than exiting the sub. I have acheived this for one row, the code I am using is:
Dim StartDate As Date
Dim EndDate As Date
Dim NoDays As Integer
If Range("L13") <> "No" Then
Exit Sub
End If
StartDate = Range("J13").Value
EndDate = Range("K13").Value
NoDays = EndDate - StartDate + 1
Range("P13").Value = StartDate
Range("P13").Resize(NoDays).DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:= _
xlDay, Step:=1, Stop:=EndDate, Trend:=False
This works for one set.
I have no idea how to loop through each of the sets which could be as many as 12,000 rows.
Can't say I knowe exactly what you are after, but this will loop through row 13 to 1000 and process your code.
Sub DateThing()
Dim StartDate As Date
Dim EndDate As Date
Dim NoDays As Integer
Dim i As Long
For i = 13 To 1000
If Range("L" & i) = "No" Then
StartDate = Range("J" & i).Value
EndDate = Range("K" & i).Value
NoDays = EndDate - StartDate + 1
Range("P" & i).Value = StartDate
Range("P" & i).Resize(NoDays).DataSeries Rowcol:=xlRows, Type:=xlChronological, Date:= xlDay, Step:=1, Stop:=EndDate, Trend:=False
end if
Next i
End Sub