I am trying to compare today's date with dates in a planning to highlight the current task.
Sub tasks()
Dim task As Range
Dim i As Integer
Dim debut As Date, fin As Date, today As Date
today = (Date)
With Worksheets("Gantt")
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
debut = (.Cells(i, 2).Value)
fin = (.Cells(i, 3).Value)
Set task = Range(.Cells(i, 1), .Cells(i, 5))
If (debut <= today) & (today <= fin) Then
'task.Interior.ColorIndex = 8
Debug.Print "today = " & today
Debug.Print "debut = " & debut
Debug.Print "fin = " & fin
End If
Next i
End With
End Sub
My code gives me an incompatibility type error in my if statement. I have tried to cast all my dates to double type with CBdl but it gives me the same error regardless.
The dates in the sheet are "long dates" and I wrote them as 20/02/2020 for example.
Does anyone know what I am missing? Thank you in advance!
You're using & instead of And which is trying to concatenate the two dates rather than logically compare the two operations.
Replace with
If (debut <= today) And (today <= fin) Then
Found two bugs on below two lines.
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If (debut <= today) & (today <= fin) Then
Below is the corrected code:
Sub tasks()
Dim task As Range
Dim i As Integer
Dim debut As Date, fin As Date, today As Date
today = (Date)
With Worksheets("Gantt")
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
debut = (.Cells(i, 2).Value)
fin = (.Cells(i, 3).Value)
Set task = Range(.Cells(i, 1), .Cells(i, 5))
If (debut <= today) And (today <= fin) Then
'task.Interior.ColorIndex = 8
Debug.Print "today = " & today
Debug.Print "debut = " & debut
Debug.Print "fin = " & fin
End If
Next i
End With
End Sub
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 have a date in cell A1 for example: 12/08/22
I want create a list with all days of the month (1-31) in column E using the month and year of the cell A1 as parameter.
Sub TESTEEEEEEE()
Dim r As Range, i As String, j As Long
i = Range("A1").Offset(0, 1).Value = Left(cell.Value, 3)
'k = ????
j = 31
For Each r In Range("E1:E31")
r.NumberFormat = "#"
r.Value = Format(DateSerial(k, i, j), "dd/m/yy")
j = j + 1
Next r
End Sub
I'm stucked in how to extract the the month and year. I was trying using the position of the characteres as parameter, but i'm not getting it work.
i should extract the 4,5 and characterer returning 08 (ok, the code is wrong i was making some tests).
k should extract the 7,8 charachter returning 22.
Someone can help me?
Please, try using the next way. It does not need iteration:
Sub testCreateWholeMonth()
Dim D As Date, lastD As Long
D = Range("A1").value
lastD = Day(WorksheetFunction.EoMonth(DateSerial(Year(D), Month(D), 1), 0))
With Range("E1:E" & lastD)
.value = Evaluate("date(" & Year(D) & "," & Month(D) & ",row(1:" & lastD & "))")
.NumberFormat = "mm.dd.yyyy"
End With
End Sub
You are probably after calendar functions like YEAR, MONTH, EOMONTH
Sub DebugDate()
Dim rg As Range
Set rg = Range("A1") ' should contain a date
Dim dt As Date
dt = rg.Value
Debug.Print Year(dt), Month(dt), CDate(WorksheetFunction.EoMonth(dt, 0))
' End of month not using worksheet function EOMONTH
Debug.Print DateSerial(Year(dt), Month(dt) + 1, 1) - 1
End Sub
Further reading on How to create a calendar with VBA
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.
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
I'm trying to write a VBA to find the date in a summary sheet and populate the data to a calendar for employee vacation tracking.
The data in Summary page looks like this
Month Employee Vacation Type Start Date End Date Time
Feb Carl Half Day PM 2/26/2015 2/26/2015
Feb Hurness Half Day PM 2/26/2015 2/26/2015
Feb Edna Half Day AM 1/18/2016 2/26/2015
I wrote the code below to populate single line. I'd like to know how to populate multiple entries to calendat base on difference of start and end date
Thanks in advance for any help!
Sub AddToCalendar()
Dim R As Range
Dim lastRow As Long
Dim startDate As Integer
Dim Employee As String
Dim Reason As String
Dim Time As String
Dim sSheet As String
'locate the info in the last row of the Summary sheet
lastRow = Sheets("Summary").Cells(Rows.Count, 4).End(xlUp).row
Employee = Sheets("Summary").Cells(lastRow, 2).Value
Reason = Sheets("Summary").Cells(lastRow, 3).Value
Time = Sheets("Summary").Cells(lastRow, 6).Value
'active the worksheet of relevant month
sSheet = Sheets("Summary").Cells(lastRow, 1).Value
Worksheets(sSheet).Activate
'locate the cell of specific date and enter data
startDate = Day(Sheets("Summary").Cells(lastRow, 4).Value)
endDate = Day(Sheets("Summary").Cells(lastRow, 5).Value)
With Sheets(sSheet)
If startDate = endDate Then
Set R = .Range("A1:H58").Find(startDate)
If Not R Is Nothing Then
Sheets(sSheet).Cells(R.row + 1, R.Column).Value = Employee & " " & Reason & " " & Time
End If
Else
Do Until startDate = endDate
startDate = startDate + 1
Set R = .Range("A1:H58").Find(startDate)
If Not R Is Nothing Then
Sheets(sSheet).Cells(R.row + 1, R.Column).Value = Employee & " " & Reason & " " & Time
End If
Loop
End If
End With
End Sub
I tried to add the code to skip weekends, but I'm a bit comfused witht the logic here. Here's what I've done, could you have a look and see what's wrong please? Thanks a lot!
For i = 1 To TotalDaysOff
With Sheets(sSheet)
Set R = .Range("A1:H58").Find(startDate + (i - 2))
If Not R Is Nothing Then
Sheets(sSheet).Cells(R.row + 1, R.Column).Value = Employee & " " & Reason & " " & Time
If skipWeekend >= 6 Then
Sheets(sSheet).Cells(R.row + 1, R.Column).Value = ""
Else
Sheets(sSheet).Cells(R.row + 1, R.Column).Value = Employee & " " & Reason & " " & Time
End If
End If
To enter multiple lines on the summary sheet based on a date range (different start date and end date), your best bet is to first figure out how many days off the employee took. This is a fairly simple arithmetic calculation, such as:
TotalDaysOff = EndDate - StartDate + 1
[NOTE: We have to add 1 to the formula to get the correct number of days. For example 2/26/2015 - 2/26-2015 would equal 0, but we know it's actually 1].
Once we have the TotalDaysOff calculated, we can create a simple loop to populate each row, such as:
If TotalDaysOff = 1 then
With Sheets(sSheet)
Set R = .Range("A1:H58").Find(startDate)
If Not R Is Nothing Then
Sheets(sSheet).Cells(R.row + 1, R.Column).Value = Employee & " " & Reason & " " & Time
End If
End With
Else
for i = 1 to TotalDaysOff
With Sheets(sSheet)
Set R = .Range("A1:H58").Find(startDate + (i - 1))
If Not R Is Nothing Then
Sheets(sSheet).Cells(R.row + 1, R.Column).Value = Employee & " " & Reason & " " & Time
End If
End With
Next i
End If
Does this work for you?