So I have a list of dates that I am trying to search through and check if they need to be corrected or not. The yellow highlighted cells are examples of changes needed to be made. Wether the date needs fixing or not I want the result of the code to place it in the "Date Fixed" column as shown in the first cell. If the date is not listed as the 30/31st of a month or the 1st then I need to change the day part of the date to either the beginning or end of the month. I have written what I thought would work but I keep receiving a Run Time Error 11 code. Any ideas on how to fix this and keep going through all the dates?
Private Sub FormatDate_Click()
Dim myrow As Integer
Dim startrow As Integer
Dim Dates As Date
Dim Datesfixed As Date
Dim dateTwo As Date
Dim dateEnd As Date
myrow = 2
startrow = 2
Dates = Cells(myrow, 2)
Datesfixed = Cells(myrow, 3)
dateTwo = mm / 1 / yyyy
dateEnd = mm / 31 / yyyy
Do Until Cells(myrow, 1) = ""
If Dates = dateTwo Or dateEnd Then
Datesfixed = Dates
ElseIf Dates <> dateTwo Or dateEnd Then
Dates = dateTwo
myrow = myrow + 1
End If
myrow = myrow + 1
Loop
myrow = 2
startrow = 2
End Sub
Try something like this:
Private Sub FormatDate_Click()
Dim c As Range, dt, d As Long, m As Long, y As Long, dLast As Long
Set c = ActiveSheet.Range("B2") 'first date
Do While Len(c.Value) > 0
dt = c.Value
d = Day(dt) 'extract the parts of the date
m = Month(dt)
y = Year(dt)
dLast = Day(DateAdd("m", 1, DateSerial(y, m, 1)) - 1) 'last day of the month
If d <> 1 And d <> dLast Then
c.Offset(0, 1) = DateSerial(y, m, dLast) 'set to last day of the month
End If
Set c = c.Offset(1, 0) 'next date
Loop
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 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 creating a sub that creates a time sheet for a specific month/year. The code is based on this Microsoft example code. The Microsoft code creates this calendar. I'm amending the code to insert the days of the week in a single column, like this.
My amended code correctly inserts the number 1 in the cell corresponding to the first day of the month, but the loop to add the subsequent day numbers does not work; Cell.Value = Cell.Offset(-1, 0).Value + 1 gives a Type Mismatch Error. Here is my amended code:
Sub Calendar_Genorator1()
Dim WS As Worksheet
Dim MyInput As Variant
Dim StartDay As Variant
Dim DayofWeek As Variant
Dim CurYear As Variant
Dim CurMonth As Variant
Dim FinalDay As Variant
Dim Cell As Range
Dim RowCell As Long
Dim ColCell As Long
Set WS = ActiveWorkbook.ActiveSheet
MyInput = InputBox("Type in Month and year for Calendar ")
If MyInput = "" Then Exit Sub
' Get the date value of the beginning of inputted month.
StartDay = DateValue(MyInput)
' Check if valid date but not the first of the month
' -- if so, reset StartDay to first day of month.
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & Year(StartDay))
End If
' Prepare cell for Month and Year as fully spelled out.
'Range("B3").NumberFormat = "d-mmmm"
'Set headers
Range("a1").Value = Application.Text(MyInput, "mmmm") & " Time Sheet"
Range("a2") = "Day"
Range("b2") = "Date"
Range("c2") = "Time In"
Range("d2") = "Time Out"
Range("e2") = "Hours"
Range("f2") = "Notes"
Range("g2") = "Overtime"
'Set weekdays
Range("a3") = "Sunday"
Range("a4") = "Monday"
Range("a5") = "Tuesday"
Range("a6") = "Wednesday"
Range("a7") = "Thursday"
Range("a8") = "Friday"
Range("a9") = "Saturday"
DayofWeek = Weekday(StartDay)
' Set variables to identify the year and month as separate variables.
CurYear = Year(StartDay)
CurMonth = Month(StartDay)
' Set variable and calculate the first day of the next month.
FinalDay = DateSerial(CurYear, CurMonth + 1, 1)
' Place a "1" in cell position of the first day of the chosen month based on DayofWeek.
Select Case DayofWeek
Case 1
Range("b3").Value = 1
Case 2
Range("b4").Value = 1
Case 3
Range("b5").Value = 1
Case 4
Range("b6").Value = 1
Case 5
Range("b7").Value = 1
Case 6
Range("b8").Value = 1
Case 7
Range("b9").Value = 1
End Select
'Loop through range b3:b44 incrementing each cell after the "1" cell.
For Each Cell In Range("b3:b44")
RowCell = Cell.Row
ColCell = Cell.Column
' Do if "1" is in column B or 2.
If Cell.Row = 1 And Cell.Column = 2 Then
' Do if current cell is not in 1st column.
ElseIf Cell.Row <> 1 Then
If Cell.Offset(-1, 0).Value >= 1 Then
Cell.Value = Cell.Offset(-1, 0).Value + 1 'Type Mismatch Error here
' Stop when the last day of the month has been entered.
If Cell.Value > (FinalDay - StartDay) Then
Cell.Value = ""
' Exit loop when calendar has correct number of days shown.
Exit For
End If
End If
End If
Next
End Sub
I changed the parameters in the loop to work inserting the days incrementally in column B, and I suspect the error is related to that. Any ideas as to why I'm getting an error for Cell.Value = Cell.Offset(-1, 0).Value + 1?
Monthly Calendar
Option Explicit
Sub Calendar_Genorator1()
Const TitleAddress As String = "A1"
Const HeadersAddress As String = "A2"
Const DaysAddress As String = "A3"
Dim Headers As Variant
Headers = Array("Day", "Date", "Time In", "Time Out", "Hours", _
"Notes", "Overtime")
Dim MyInput As Variant, StartDay As Variant
MyInput = InputBox("Type in setMonth and year for Calendar ")
If MyInput = "" Then Exit Sub
' Get the date value of the beginning of inputted Month.
StartDay = DateValue(MyInput)
' Check if valid date but not the first of the Month
' -- if so, reset StartDay to first day of Month.
If Day(StartDay) <> 1 Then
StartDay = DateValue(Month(StartDay) & "/1/" & Year(StartDay))
End If
Dim ws As Worksheet
Set ws = ActiveWorkbook.ActiveSheet
' Write title.
ws.Range(TitleAddress).Value = Application.Text(StartDay, "mmmm") _
& " Time Sheet"
' Write headers.
ws.Range(HeadersAddress).Resize(, UBound(Headers)) = Headers
' Write days.
Dim Target As Variant
Target = getDDDD_D_US(Month(StartDay), Year(StartDay))
ws.Range(DaysAddress).Resize(UBound(Target), UBound(Target, 2)).Value = Target
End Sub
Function getDDDD_D_US(setMonth As Long, setYear As Long)
Dim DaysData As Variant
DaysData = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", _
"Friday", "Saturday")
Dim Result As Variant
ReDim Result(1 To 42, 1 To 2)
' Write DDDD column.
Dim i As Long, j As Long, k As Long
For i = 1 To 6
k = (i - 1) * 7 + 1
For j = 0 To 6
Result(k + j, 1) = DaysData(j)
Next j
Next i
' Write D column.
Dim Current As Date
Current = DateSerial(setYear, setMonth, 1)
i = Weekday(Current)
For i = i To i + 27
Result(i, 2) = Day(Current)
Current = Current + 1
Next i
For i = i To i + 2
If Month(Current) = setMonth Then
Result(i, 2) = Day(Current)
Current = Current + 1
End If
Next i
getDDDD_D_US = Result
End Function
I have a problem I hope I can get some help with. In a summary report I need to use date criterias: today's date compared to months in B1:M1 (all cells are date formatted using a userdefined date format to only display the monthname) to sum the rows of data only if an account number is listed in column A. (pls. see below example)
I.E. if todays date is Feb. 7th the VBA code should loop through all rows and only sum the numbers for January and february where an account # is present (it must be in VBA)
Here is what I have so far:
Sub Test()
Dim today, lastdayinmonth As Date
Dim i, ii As Integer
Dim months As Range
today = DateSerial(Year(Date), Month(Date), Day(Date))
lastdayinmonth = DateSerial(Year(Date), Month(Date) + 1, 0)
months = Sheet2.Range("B2:M2")
If idag <= lastdayinmonth Then
For i = 3 To 20
If Not IsEmpty(Sheet2.Range("B" & i)) Then
End If
Next ii
End If
End Sub
Try this code, please. It works based on the assumption that your columns header are Date formatted (no matter if they show only month...), and the sum will be returned in Imediate Window:
Sub TestSumMonth()
Dim arrM As Variant, i As Long, j As Long
Dim nSum As Long, lastRow As Long, sh As Worksheet
Set sh = sheet2
lastRow = sh.Range("A" & sh.Rows.count).End(xlUp).Row
arrM = sh.Range("A1:M" & lastRow).Value
sh.Range("O2:O" & lastRow).Interior.ColorIndex = xlNone ' clear the existing interior color
For i = 1 To UBound(arrM, 1)
If arrM(i, 1) <> Empty Then
nSum = 0
For j = 2 To UBound(arrM, 2)
If Month(Date) >= Month(arrM(1, j)) Then
nSum = nSum + arrM(i, j)
If Month(Date) = Month(arrM(1, j)) Then
With sh.Range("O" & i)
.Value = nSum
.Interior.Color = vbYellow ' interior colored in yellow
End With
Exit For
End If
End If
Next j
End If
Next i
End Sub
The code firstly clears "O:O" range interior color, then returns the sum on the appropriate row of this column and colors the cell interior in yellow...
Now, it would summarize all the passed month values plus the active month.