I have the following piece of code, which is excluding all results in excel sheet that have date different than today + 6 days.
The problem is that when I execute that on Monday I hit Sunday.
I need to change it in a way that it will add always 6 days to my current date unless the result is Saturday or Sunday, then I would like to take the first working day after that, meaning - Monday.
Public Sub GRP_SC_Filter1()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim DelDate As Long
DelDate = DateSerial(Year(Date), Month(Date), Day(Date) + 6)
LR = Sheets("Goods Receivable Planning").Range("A" & Rows.Count).End(xlUp).Row
Cells.AutoFilter Field:=13, Criteria1:="<>" & DelDate
ALR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
If ALR > 2 Then
Range("A2:A" & LR).SpecialCells(xlCellTypeVisible).Select
Range("A2:A" & LR).Delete
Range("A1").Activate
End If
Cells.AutoFilter
' MsgBox "Finished deleting rows"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I would be really thankful if somebody could help me transforming this into what I need. I am honestly stuck. Thank you in advance!
This function should do what you want:
Function GetNextWorkingDay(dt As Date) As Date
Select Case Weekday(dt)
Case 1
GetNextWorkingDay = DateAdd("d", 1, dt)
Case 7
GetNextWorkingDay = DateAdd("d", 2, dt)
Case Else
GetNextWorkingDay = dt
End Select
End Function
The function weekDay can hep you. The second parameter defines what day return 1, vbMonday would say that Mondays are 1, Saturday = 6, Sunday = 7
So, one way would be:
deldate = DateSerial(Year(Date + 3), Month(Date + 3), Day(Date + 3) + 6)
Do While (Weekday(deldate, vbMonday) >= 6)
deldate = deldate + 1
Loop
Related
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 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
I am struggling with working this one out. Basically, what I currently have is code to open the previous working days file.
x = Weekday(Date, vbSunday)
Select Case x
Case 1
x = 2
Case 2
x = 3
Case Else
x = 1
End Select
Workbooks.Open Filename:= _
"filepath" & Format(Date - x, "yymmdd") & " - filename.xlsx"
Obviously the above doesn't take into consideration Bank/Public Holidays. How can I build this into my code, so for example:
Thursday 29/03/2018 - Working day
Friday 30/03/2018 - Good Friday (Bank Holiday)
Monday 02/04/2018 - Easter Monday (Bank Holiday)
Tuesday 03/04/2018 - Working day
When I come in on Tuesday and run my macro I want it to pick up the last working days file and use that (Thursday 29/03). With my current code that wouldn't be picked up and it would be looking for Mondays file (which obviously doesn't exist).
I hope that makes sense !
Thanks,
Jason
You can get the last previous workday with the
WorksheetFunction.WorkDay Method or
WorksheetFunction.WorkDay_Intl Method
(which lets you choose which days in a week are the weekend)
So get the last previous workday with …
Dim LastPreviousWorkday As Date
LastPreviousWorkday = Application.WorksheetFunction.WorkDay(Date(), -1)
And eg. output it formatted
Format$(LastPreviousWorkday, "yymmdd")
You can tell the WorkDay function which dates (additionally to weekends) should be considered as holidays, eg by giving an array or range as third argument.
Dim BankHolidays As Variant
BankHolidays = Array(#3/26/2018#, #3/23/2018#) 'array of bank holidays, or a range in a
'sheet where the dates of bank holidays
'are saved in.
Dim LastPreviousWorkday As Date
LastPreviousWorkday = Application.WorksheetFunction.WorkDay(Date, -1, BankHolidays)
or if you want to use a worksheet with holiday dates
Application.WorksheetFunction.WorkDay(Date, -1, Worksheets("MyHolidays").Range("A:A"))
'considers all dates in column A of sheet MyHolidays as non-workdays
This is an over the top answer - the bulk of the code is figuring out which days are bank holidays (in the UK) and gets the main ones (royal weddings/deaths withstanding).
You'll also need a worksheet in your file called Holidays and it will create a named range called "BankHolidays".
Then it just uses the Workday formula that #Peh used in his answer.
Public Sub Test()
Dim CurrentWorkDay As Date
Dim LastWorkDay As Date
Dim wrkBk_To_Open As Workbook
'Day after Easter Monday.
CurrentWorkDay = DateSerial(2018, 4, 3)
'CHANGE YEAR AS REQUIRED - all other procedures are because of this.
DisplayBankHolidays 2018
'THIS IS THE ONLY IMPORTANT LINE OF CODE - THE ONE THAT CALCULATES THE LAST WORK DAY.
LastWorkDay = Application.WorksheetFunction.WorkDay(CurrentWorkDay, -1, Range("BankHolidays"))
MsgBox Format(LastWorkDay, "ddd dd mmm yy"), vbOKOnly
'Set wrkBk_To_Open = Workbooks.Open("filepath\" & Format(LastWorkDay, "yymmdd") & " - filename.xlsx")
'msgbox wrkbk_to_open.name & vbcr & "contains " & wrkbk_to_open.sheets.count & " sheets."
End Sub
Public Sub DisplayBankHolidays(lYear As Long)
Dim BH As Collection
Dim vBH As Variant
Dim lRow As Long
Dim HolidaySheet As Worksheet
Set BH = New Collection
Set HolidaySheet = ThisWorkbook.Worksheets("Holidays")
Set BH = BankHolidays(lYear)
lRow = HolidaySheet.Cells(HolidaySheet.Rows.Count, 1).End(xlUp).Row + 1
For Each vBH In BH
Sheet1.Cells(lRow, 1) = vBH
lRow = lRow + 1
Next vBH
With HolidaySheet
.Range(.Cells(1, 1), .Cells(lRow, 1)).RemoveDuplicates 1, xlNo
AllocateNamedRange ThisWorkbook, "BankHolidays", "='" & HolidaySheet.Name & "'!" & .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)).Address, "A1"
End With
End Sub
'This could be improved - just haven't had time yet.
Public Function BankHolidays(lYear As Long) As Collection
Dim colTemp As Collection
Dim dDateInQuestion As Date
Dim dTemp As Date
Set colTemp = New Collection
'New Years Day
'If falls on a weekend then following Monday is BH.
dDateInQuestion = DateSerial(lYear, 1, 1)
If Weekday(dDateInQuestion, vbMonday) >= 6 Then
dTemp = dDateInQuestion + 8 - Weekday(dDateInQuestion, vbMonday)
Else
dTemp = dDateInQuestion
End If
colTemp.Add dTemp, "NewYearsDay"
'Easter
'Easter is the Sunday so isn't added,
'but Good Friday & Easter Monday are calculated from this date.
dTemp = EasterDate(CInt(lYear))
colTemp.Add dTemp - 2, "GoodFriday"
colTemp.Add dTemp + 1, "EasterMonday"
'Early May Bank Holiday.
'First Monday in May.
dDateInQuestion = DateSerial(lYear, 5, 1)
If Weekday(dDateInQuestion, vbMonday) > 1 Then
dTemp = dDateInQuestion + 8 - Weekday(dDateInQuestion, vbMonday)
Else
dTemp = dDateInQuestion
End If
colTemp.Add dTemp, "EarlyMayBankHoliday"
'Spring Bank Holiday
'Last Monday in May.
dDateInQuestion = DateSerial(lYear, 6, 1)
dTemp = dDateInQuestion - Weekday(dDateInQuestion, vbTuesday)
colTemp.Add dTemp, "SpringBankHoliday"
'Summer Bank Holiday
dDateInQuestion = DateSerial(lYear, 9, 1)
dTemp = dDateInQuestion - Weekday(dDateInQuestion, vbTuesday)
colTemp.Add dTemp, "SummerBankHoliday"
'Christmas Day
'Records 25th as BH and following Monday if Christmas is on Saturday or
'following Tuesday if Christmas is on Sunday.
dDateInQuestion = DateSerial(lYear, 12, 25)
If Weekday(dDateInQuestion, vbMonday) = 6 Then
dTemp = dDateInQuestion + 8 - Weekday(dDateInQuestion, vbMonday)
colTemp.Add dTemp, "ChristmasDay"
ElseIf Weekday(dDateInQuestion, vbMonday) = 7 Then
dTemp = dDateInQuestion + 8 - Weekday(dDateInQuestion, vbMonday) + 1
colTemp.Add dTemp, "ChristmasDay"
Else
colTemp.Add dDateInQuestion, "ChristmasDay"
End If
'Boxing Day
'Records 26th as BH.
'If 26th is Saturday, then following Monday is BH.
'If 26th is Sunday, then following Tuesday is BH.
dDateInQuestion = DateSerial(lYear, 12, 26)
If Weekday(dDateInQuestion, vbMonday) = 6 Then
dTemp = dDateInQuestion + 8 - Weekday(dDateInQuestion, vbMonday)
colTemp.Add dTemp, "BoxingDay"
ElseIf Weekday(dDateInQuestion, vbMonday) = 7 Then
dTemp = dDateInQuestion + 9 - Weekday(dDateInQuestion, vbMonday)
colTemp.Add dTemp, "BoxingDay"
Else
colTemp.Add dDateInQuestion, "BoxingDay"
End If
Set BankHolidays = colTemp
End Function
'---------------------------------------------------------------------------------------
' Procedure : EasterDate
' Author : Chip Pearson
' Site : http://www.cpearson.com/excel/Easter.aspx
' Purpose : Calculates which date Easter Sunday is on. Is good from 1900 to 2099.
'---------------------------------------------------------------------------------------
Public Function EasterDate(Yr As Integer) As Date
Dim d As Integer
d = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
EasterDate = DateSerial(Yr, 3, 1) + d + (d > 48) + 6 - ((Yr + Yr \ 4 + _
d + (d > 48) + 1) Mod 7)
End Function
Public Function NamedRangeExists(Book As Workbook, sName As String) As Boolean
On Error Resume Next
NamedRangeExists = Book.Names(sName).Index <> (Err.Number = 0)
On Error GoTo 0
End Function
Public Sub AllocateNamedRange(Book As Workbook, sName As String, sRefersTo As String, Optional ReferType = "R1C1")
With Book
If NamedRangeExists(Book, sName) Then .Names(sName).Delete
If ReferType = "R1C1" Then
.Names.Add Name:=sName, RefersToR1C1:=sRefersTo
ElseIf ReferType = "A1" Then
.Names.Add Name:=sName, RefersTo:=sRefersTo
End If
End With
End Sub
I have created a VBA to automatically populate yesterday's date in a cell, but need assistance as how should get the date as 16th June(Friday) instead of 18th June(which is a Sunday) when I trigger it on Monday.
`If .Column <> 11 Or .Row < 1 Then Exit Sub
If .Value = "Select" Then
If .Offset(0, 1).Value = "" Then
.Offset(0, 1).NumberFormat = "mm/dd/yy"
.Offset(0, 1).Value = Now - 1
.Offset(0, 2).Value = Now - 1
.Offset(0, 2).NumberFormat = "mmm-yy" '<~~ mmm-yy
.Offset(0, 3).Value = GetMonthWeek(Now - 1)
End If'
I am not sure if there is any inbuilt method for that, but the following logic works:
Dim tempDate
tempDate = DateAdd("d", -1, Date) 'Today's date - 1
While Weekday(tempDate) = 1 Or Weekday(tempDate) = 7 'If tempDate is a Sunday or a Saturday, keep on subtracting one day until we get a weekday
tempDate = DateAdd("d", -1, tempDate)
Wend
Cells(1, 1).Value = tempDate
Try implementing this in your code and let me know if it works. :)
Worksheet functions can easily retrieve the previous Friday whether or not the current day is a Friday.
'last Friday regardless
=A2-WEEKDAY(A2, 16)
'last Friday unless a Friday
=A2-WEEKDAY(A2, 16)+(WEEKDAY(A2)=6)*7
WEEKDAY and boolean operations are directly transferable to VBA.
The target is that I am making a small tool to be made in VBA Excel.
The task description is as follows:
1- Make a function in VBA code which would highlight the fixed holidays in the provided Calendar (New Year 01/01 , Labor Day 01/05 , Christmas Day 25/12 , Christmas Holiday 26/12)
2-Make a function in VBA code which would highlight the floating holidays in the provided Calendar (Easter Monday,Good Friday).
3-The worksheets in the workbook should be hyperlinked through the VBA code to a Business day ( Business days are from "Monday to Friday") , there is a condition here too. If the Business day in future calendar happen to be a Fixed Holiday or the Floating Holiday e.g There is New Year on a Tuesday so there would be a holiday observed, in such scenario the worksheet should not be available for this holiday date. In other words, the worksheets have tasks which are to be performed on Business Days only.So if there is a Holiday (irrespective of Fixed or Floating Holiday) the task worksheet containing the task information would not be available.
My issue is that I dont have much of knowledge in VBA.Through internet searches I have found the functions but how to integrate them to achieve the above?
My code and so far found stuff is following:
Public Sub Worksheet_Change(ByVal Target As Range)
Dim mth As Integer, b As Integer, dt As Integer, M As Integer, x As Integer, _
w As Integer, Y As Integer, Days As Integer, iRow As Integer
Dim dateDay1 As Date, dateLeapYear As Date, calYearCell As Range
Dim ws As Worksheet
Dim monthName(1 To 12) As String, weekDay(1 To 7) As String
On Error GoTo ResetApplication
'will enable events (worksheet change) on error
'check validity of worksheet name:
If Not ActiveSheet.Name = "Calendar" Then
MsgBox "Please name worksheet as 'Calendar' to continue"
Exit Sub
End If
Set ws = Worksheets("Calendar")
'address of cell/range which contains Calendar Year:
Set calYearCell = ws.Range("H7")
'At least one cell of Target is within the range - calYearCell:
If Not Application.Intersect(Target, calYearCell) Is Nothing Then
'turn off some Excel functionality so the code runs faster
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
If calYearCell = "" Then
MsgBox "Select Year to Generate Calendar"
GoTo ResetApplication
Exit Sub
End If
'clear first 7 columns and any previous calendar:
ws.Range("A:G").Clear
D = 0
'set names of 12 months for the array monthName:
monthName(1) = "January"
monthName(2) = "February"
monthName(3) = "March"
monthName(4) = "April"
monthName(5) = "May"
monthName(6) = "June"
monthName(7) = "July"
monthName(8) = "August"
monthName(9) = "September"
monthName(10) = "October"
monthName(11) = "November"
monthName(12) = "December"
'set names of 7 week days for the array weekDay:
weekDay(1) = "Monday"
weekDay(2) = "Tuesday"
weekDay(3) = "Wednesday"
weekDay(4) = "Thursday"
weekDay(5) = "Friday"
weekDay(6) = "Saturday"
weekDay(7) = "Sunday"
For mth = 1 To 12
'for each of the 12 months in a year
counter = 1
'determine day 1 for each month:
If mth = 1 Then
dateDay1 = "1/1/" & calYearCell
wkDay = Application.Text(dateDay1, "dddd")
If wkDay = "Monday" Then
firstDay = 1
ElseIf wkDay = "Tuesday" Then
firstDay = 2
ElseIf wkDay = "Wednesday" Then
firstDay = 3
ElseIf wkDay = "Thursday" Then
firstDay = 4
ElseIf wkDay = "Friday" Then
firstDay = 5
ElseIf wkDay = "Saturday" Then
firstDay = 6
ElseIf wkDay = "Sunday" Then
firstDay = 7
End If
Else
firstDay = firstDay
End If
'determine number of days in each month and the leap year:
dateLeapYear = "2/1/" & calYearCell
M = month(dateLeapYear)
Y = Year(dateLeapYear)
Days = DateSerial(Y, M + 1, 1) - DateSerial(Y, M, 1)
If mth = 1 Or mth = 3 Or mth = 5 Or mth = 7 Or mth = 8 Or mth = 10 Or mth = 12 Then
mthDays = 31
ElseIf mth = 2 Then
If Days = 28 Then
mthDays = 28
ElseIf Days = 29 Then
mthDays = 29
End If`Else
mthDays = 30
End If
`
'determine last used row:
If mth = 1 Then
iRow = 0
Else
iRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
End If
dt = 1
'maximum of 6 rows to accomodate all days of a month:
For i = 1 To 6
'7 columns for each week day of Monday to Sunday:
For b = 1 To 7
'enter name of the month:
ws.Cells(iRow + 1, 1) = monthName(mth)
ws.Cells(iRow + 1, 1).Font.Color = RGB(0, 0, 200)
ws.Cells(iRow + 1, 1).Font.Bold = True
ws.Range("A" & iRow + 1 & ":G" & iRow + 1).Interior.Color = RGB(191, 191, 191)
ws.Range("A" & iRow + 1 & ":G" & iRow + 1).Borders(xlEdgeTop).LineStyle = XlLineStyle.xlContinuous
'enter week day (Monday, Tuesday, ...):
ws.Cells(iRow + 2, b) = weekDay(b)
ws.Range("A" & iRow + 2 & ":G" & iRow + 2).Font.Bold = True
ws.Range("A" & iRow + 2 & ":G" & iRow + 2).Interior.Color = RGB(0, 5000, 0)
ws.Range("F" & iRow + 2 & ":G" & iRow + 2).Interior.Color = RGB(5000, 0, 0)
'enter each date in a month:
If dt <= mthDays Then
'dates placement for the first row (for each month):
If firstDay > 1 And counter = 1 Then
For x = 1 To 8 - firstDay
ws.Cells(iRow + 2 + i, firstDay + x - 1) = x
Next x
dt = 9 - firstDay
'after placement of dates in the first-row for a month the counter value changes to 2, and then reverts
to 1 for the next month cycle:
counter = 2
w = 1
End If
'dates placement after the first row (for each month):
ws.Cells(iRow + 2 + i + w, b) = dt
dt = dt + 1
End If
Next b
Next i
w = 0
'determine placement of day 1 for each month after the first month:
firstDay = firstDay + mthDays Mod 7
If firstDay > 7 Then
firstDay = firstDay Mod 7
Else
firstDay = firstDay
End If
Next mth
'formatting:
iRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
ws.Range("A" & iRow & ":G" & iRow).Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlContinuous
ws.Range("G1:G" & iRow).Borders(xlEdgeRight).LineStyle = XlLineStyle.xlContinuous
With ws.Range("A1:G" & iRow)
.Font.Name = "Arial"
.Font.Size = 9
.RowHeight = 12.75
.HorizontalAlignment = xlCenter
.ColumnWidth = 9
End With
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
ResetApplication:
Err.Clear
On Error GoTo 0
Application.EnableEvents = True
End Sub
' for floating holidays
Public Sub floatingholidays(NDow As Date, Y As Integer, M As Integer, _
N As Integer, DOW As Integer)
NDow = DateSerial(Y, M, (8 - weekDay(DateSerial(Y, M, 1), _
(DOW + 1) Mod 8)) + ((N - 1) * 7))
End Sub
'for Easter date determination
Public Sub EasterDate(EasterDate2 As Date, Yr As Integer)
Dim D As Integer
D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
EasterDate2 = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - ((Yr + Yr \ 4 + _
D + (D > 48) + 1) Mod 7)
End Sub
You will not get a question like this answered here. You specify a large requirement and provide a large chunk of code that does not obviously relate to the requirement.
You must break this question into parts, attempt to solve those parts yourself.
For example:
Public Sub floatingholidays(NDow As Date, Y As Integer, M As Integer, _
N As Integer, DOW As Integer)
NDow = DateSerial(Y, M, (8 - weekDay(DateSerial(Y, M, 1), _
(DOW + 1) Mod 8)) + ((N - 1) * 7))
End Sub
Add some comments to this sub-routine explaining what it does. When you return to this routine in 12 months, will you remember how it works?
Does this sub-routine set NDow to the correct value? Test it using macros like this:
Sub TestFH()
Call TestFHSub(2014, 1, 14, 5)
Call TestFHSub(2013, 1, 10, 1)
Call TestFHSub(2013, 2, 6, 2)
Call TestFHSub(2013, 5, 7, 3)
End Sub
Sub TestFHSub(ByVal Y As Integer, ByVal M As Integer, ByVal N As Integer, ByVal DOW As Integer)
Dim NDow As Date
Call floatingholidays(NDow, Y, M, N, DOW)
Debug.Print "If Y=" & Y & " M=" & M & " N=" & N & " DOW=" & DOW & " Then NDow=" & NDow
End Sub
I doubt the values I used in my calls of TestFHSub are sensible. Replace them with a good selection of values so you are convinced this routine works as required. If you need help ask a question about floatingholidays.
Do the same EasterDate.
Next think about how to call routine. Placing this code in a Worksheet_Change routine means it will be called every time you switch worksheet.
Discard the On Error code which just makes debugging more difficult. Consider adding it at the end of development if there is a need. There probably will not be a need.
Discard Application.DisplayAlerts = False etc. Do not worry about the speed of the macro until you have got the code working.
MonthName is a VBA function so you do not need the monthName array.
WeekdayName is a VBA function so you do not need the weekDay array.
Build your macro a few statements at a time and check they are having the effect you seek. If small block of code does not give the effect you seek, ask a question about it.
Good luck.