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
Related
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
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
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 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.
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.