i want to write a Vba for excel that allow me to write every 8 rows the date of the year starting from january 2023 till the end of december 2023 (format dd, mm, yyyy) excluding sunday of all the weeks.
If i want to reduce the distance of the only rows tha t separates saturday from monday how could i do?
attached an Example
Up to now i wrote this routine that writes every date of the year, but it does also consider sunday and the distance of 8 rows from saturday to monday that i would like to reduce to 3 rows as previously said.
Thanks
Sub Datesoftheyear()
Dim currentDate As Date
Dim endYear As Date
currentDate = Date
endYear = DateSerial(Year(Now()), 12, 31)
For i = 1 To X Step 8
Cells(i, 1).Value = Format(currentDate, "dd-mm-yyyy")
currentDate = DateAdd("d", 1, currentDate)
If currentDate > endYear Then Exit For
Next i
End Sub
You can determine if a date is Sunday using the Weekday function, or using the DatePart function with Interval:="w"
Then, in your loop, you can test for currentDate being a Sunday, and if it is, advance forward by one day.
Sub Datesoftheyear()
Dim currentDate As Date
Dim endYear As Date
currentDate = Date
endYear = DateSerial(Year(Now()), 12, 31)
For i = 1 To X Step 8
Cells(i, 1).Value = Format(currentDate, "dd-mm-yyyy")
currentDate = DateAdd("d", 1, currentDate)
'If sunday, advance to next day
If Weekday(currentDate) = vbSunday Then currentDate = DateAdd("d", 1, currentDate)
If currentDate > endYear Then Exit For
Next i
End Sub
You can use this code.
Offset is defined as constant at the beginning of the sub - like that you can change it without searching within the code.
I added an explicit activesheet.cells(1,1) - you maybe want to adjust that
I set the start date to the January 1st. of current year.
regarding the "Sunday"-check: you have to adapt that to your regional settings. For Germany, e.g. a week starts on monday and sundays weekday = 7 ...
Sub DatesOfTheYear()
'Define row offset between two dates here
Const rowOffset As Long = 3
Dim startDate As Date, endYear As Date, rowDate As Date
Dim i As Long, j As Long
startDate = DateSerial(Year(Now()), 1, 31)
endYear = DateSerial(Year(Now()), 12, 31)
Dim rg As Range
Set rg = ActiveSheet.Cells(1, 1)
For i = 0 To DateDiff("d", startDate , endYear)
rowDate = startDate + i
'!!!!
'!!! you have to check this for your country settings
'!!!!!
If Weekday(rowDate, vbMonday) <> 7 Then
rg.Offset(j * (rowOffset + 2)) = Format(rowDate, "ddd")
rg.Offset((j * (rowOffset + 2)) + 1) = rowDate
j = j + 1
End If
Next i
End Sub
Sub Datesoftheyear()
MyRow = 1
For idt=date To DateSerial(Year(date),12,31)
If mod(idt,7)<>1 Then
Cells(MyRow,1).Value = idt
MyRow = MyRow + 8
End If
Next idt
End Sub
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 have multiple leases, where I have start date and expiry dates, I would like to get the quarterly dates between the start date and expiry date with the condition that each quarter (Q1, Q2, Q3) should be 90 days but Q4 should be 365 or 366 days from the start date.
I'm attaching a screenshot for two leases, is there any excel formula or VBA to get this desired result.
any help will be much appreciated.
Quarterly Payment dates-90 days conditon
thanks
aleem
The desired results are perfect, still, I request to the excel gurus to see if any better approach is available
Sub qtrcalc()
Dim StartDate As Date
Dim EndDate As Date
Dim z As Integer
Dim ldate As Date
Dim x As Integer
Dim k As Integer
Dim Ydate As Date
StartDate = Range("c1")
EndDate = Range("c2")
z = DateDiff("q", StartDate, EndDate) '+ 1 ' for begining of the month date
ldate = DateAdd("d", 90, StartDate) 'for the end date based on freq
Range("c27").Value = ldate
Range("c27").Value = StartDate
For x = 28 To 28 + z - 2
Cells(x, 3).Value = DateAdd("d", 90, StartDate)
Ydate = Range("c1").Value
For k = 31 To 31 + z - 5 Step 4
Cells(k, 3).Value = DateAdd("yyyy", 1, Ydate)
Ydate = Cells(k, 3)
Next k
StartDate = Cells(x, 3)
Next x
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 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.