In this article, we’ll focus on automating three essential date sequence activities:
| Scenario | Description |
|---|---|
| First Date of Quarter | Extending dates to the First date of the Quarter |
| Last Date of Quarter | Extending dates to the Last date of the Quarter |
| Last Business Date of the Quarter | Extending dates to the last business day of the Quarter |
Scenario 1: First Date of Quarter
This VBA script,
titled `First_Quarter_Date_A`, is designed to extend a sequence of dates in an
Excel worksheet. Specifically, it appends dates that correspond to the first
day of each quarter for a specified number of quarters, starting from the last
date found in the existing list.
Code
```vba
Sub First_Quarter_Date_A()
Dim FLD_Count As Integer, i
As Integer, LR As Long, LRDate As Date
If
IsEmpty(ActiveSheet.Range("A2").Value) = True Then
MsgBox "Please
Enter the Date in A2 Cell"
Else
FLD_Count =
ActiveSheet.Range("C2").Value
LR =
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
LRDate =
ActiveSheet.Range("A" & LR).Value
' Insert Start Delivery
Date
For i = 1 To FLD_Count
Dim newDate As Date
newDate =
DateSerial(Year(LRDate) + i \ 4, (Month(LRDate) - 1) + (i Mod 4) * 3 + 1, 1)
ActiveSheet.Range("A" & LR + i).Value = newDate
Next i
End If
End Sub
Let's break down
the code step by step:
1. **Variable Declarations:
**
- `FLD_Count` (Integer): Stores the number
of additional last dates of the year to add.
- `i` (Integer): Used as a counter in the
loop.
- `LR` (Long): Stores the row number of the
last non-empty cell in column A.
- `LRDate` (Date): Stores the date in the
last non-empty cell in column A.
2. **Check for
Initial Date in Cell A2:**
```vba
If
IsEmpty(ActiveSheet.Range("A2").Value) Then
MsgBox "Please Enter the Date in A2
Cell"
```
- This condition checks if cell A2 is empty.
If it is, a message box prompts the user to enter a date in cell A2. This
ensures that there is an initial date to work with.
3. **Retrieve Values:
**
```vba
FLD_Count =
ActiveSheet.Range("C2").Value
LR = ActiveSheet.Range("A" &
Rows.Count).End(xlUp).Row
LRDate = ActiveSheet.Range("A"
& LR).Value
```
- `FLD_Count`: Reads the number of years to
extend from cell C2.
- `LR`: Finds the last row in column A that
contains a date.
- `LRDate`: Retrieves the date from the last
row in column A.
4. **Initialize the
First Last Date of Year:**
```vba
' Insert First Date of Quarter
For i = 1 To FLD_Count
Dim newDate As Date
newDate =
DateSerial(Year(LRDate) + i \ 4, (Month(LRDate) - 1) + (i Mod 4) * 3 + 1, 1)
ActiveSheet.Range("A" & LR + i).Value = newDate
Next i
**`For i = 1 To
FLD_Count`**: This loop runs from 1 to the value of `FLD_Count`, meaning it
will generate and insert a date for each quarter specified.
- **`newDate =
DateSerial(...)`**:
- **`Year(LRDate) + i \ 4`**: This
calculation determines the year for the new date. The `\ 4` operator is used to
increment the year after every four quarters.
- **`(Month(LRDate) - 1) + (i Mod 4) * 3 +
1`**: This part determines the month for the new date. The modulus operation
(`i Mod 4`) ensures the calculation wraps around correctly to generate dates
for the first month of each quarter (January, April, July, October).
- **`1`**: Sets the day of the new date to
the first day of the month.
-
**`ActiveSheet.Range("A" & LR + i).Value = newDate`**: Inserts
the calculated `newDate` into the next available row in column A.
The loop continues until all specified rows are filled with the first date of each quarter.
Scenario 2: Last Date of Quarter
The VBA code provided extends dates in a sequence, ensuring that the next dates fall on the last day of each subsequent quarter.
Code
```vba
Sub End_Quarter_Date_A()
Dim FLD_Count As Integer, i
As Integer, LR As Long, LRDate As Date
If
IsEmpty(ActiveSheet.Range("A2").Value) = True Then
MsgBox "Please
Enter the Date in A2 Cell"
Else
FLD_Count =
ActiveSheet.Range("C2").Value
LR =
ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
LRDate =
ActiveSheet.Range("A" & LR).Value
' Insert End Quarter
Date
For i = 1 To FLD_Count
Dim newDate As Date
newDate =
DateSerial(Year(LRDate) + i \ 4, (Month(LRDate) - 1) + (i Mod 4) * 3 + 1, 1)
ActiveSheet.Range("A" & LR + i).Value =
WorksheetFunction.EoMonth(newDate, 0)
Next i
End If
End Sub
Let's break down the code step by step:
1. **Variable Declarations: **
- `FLD_Count` (Integer): Stores the number of additional last dates of the year to add.
- `i` (Integer): Used as a counter in the loop.
- `LR` (Long): Stores the row number of the last non-empty cell in column A.
- `LRDate` (Date): Stores the date in the last non-empty cell in column A.
2. **Check for Initial Date in Cell A2:**
```vba
If IsEmpty(ActiveSheet.Range("A2").Value) Then
MsgBox "Please Enter the Date in A2 Cell"
```
- This condition checks if cell A2 is empty. If it is, a message box prompts the user to enter a date in cell A2. This ensures that there is an initial date to work with.
3. **Retrieve Values: **
```vba
FLD_Count = ActiveSheet.Range("C2").Value
LR = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
LRDate = ActiveSheet.Range("A" & LR).Value
```
- `FLD_Count`: Reads the number of years to extend from cell C2.
- `LR`: Finds the last row in column A that contains a date.
- `LRDate`: Retrieves the date from the last row in column A.
For i = 1 To FLD_Count
Dim newDate As Date
newDate =
DateSerial(Year(LRDate) + i \ 4, (Month(LRDate) - 1) + (i Mod 4) * 3 + 1, 1)
ActiveSheet.Range("A" & LR + i).Value =
WorksheetFunction.EoMonth(newDate, 0)
Next i
The loop runs FLD_Count
times, which means it will generate dates for the specified number of quarters.
newDate: A new date is calculated for each
iteration of the loop.
- DateSerial(Year(LRDate) + i \ 4, (Month(LRDate) - 1) + (i Mod 4) * 3 + 1, 1)
- Year(LRDate) + i \ 4: Increments the year every 4 quarters.
- (Month(LRDate) - 1) + (i Mod 4) * 3 + 1: Adjusts the month based on the current quarter. This calculates the month that corresponds to the last month of the quarter (March, June, September, December).
- 1: Sets the day to the first day of the month calculated.
WorksheetFunction.EoMonth(newDate,
0): Returns the last day of the month for newDate.
The calculated date
is then placed into the cell in column A at the position LR + i.
Scenario 3: Last Business Date of the Quarter
This subroutine is
designed to extend dates in a sequence, adding the last business day of each
quarter to the list.
Code
```vba
Sub End_Quarter_Business_Date_A()
Dim FLD_Count As Integer, i
As Integer, LR As Long, LRDate As Date
Dim newDate As Date
If
IsEmpty(ActiveSheet.Range("A2").Value) = True Then
MsgBox "Please Enter the Date in
A2 Cell"
Else
FLD_Count =
ActiveSheet.Range("C2").Value
LR = ActiveSheet.Range("A"
& Rows.Count).End(xlUp).Row
LRDate =
ActiveSheet.Range("A" & LR).Value
' Insert Quarter Last Delivery Date
For i = 1 To FLD_Count
newDate = DateAdd("q",
i, LRDate)
' Check if the month is March,
June, September, or December
If Month(newDate) = 3 Or
Month(newDate) = 6 Or Month(newDate) = 9 Or Month(newDate) = 12 Then
' Set the day to the last day
of the month
newDate =
DateSerial(Year(newDate), Month(newDate) + 1, 0)
' Adjust to the last business
day of the month if it's not a business day
Do While Not
IsBusinessDay(newDate)
newDate = newDate - 1
Loop
End If
ActiveSheet.Range("A"
& LR + i).Value = newDate
Next i
LRDate =
ActiveSheet.Range("A" & LR + FLD_Count).Value
End If
End Sub
- The loop runs from 1 to `FLD_Count` to
add dates to the sequence.
- **DateAdd Function:** The `DateAdd`
function adds a quarter (`"q"`) to the `LRDate` for each iteration.
- **Check for Quarter-End Months:** The
code checks if the new date is in March, June, September, or December (i.e.,
the end of a quarter).
- **DateSerial Function:** If it is,
the day is set to the last day of that month by using the `DateSerial`
function.
- **IsBusinessDay Function:** This function is part of Sub routine Sub End_Quarter_Business_Date_A(). A `Do While` loop checks if the calculated date is a business day. If it’s not (e.g., falls on a weekend), the date is decremented by one day until a business day is found.
Function IsBusinessDay(testDate As Date) As Boolean
' Check if the given date is
a business day (excluding weekends)
If Weekday(testDate,
vbMonday) < 6 Then
IsBusinessDay = True
Else
IsBusinessDay = False
End If
End Function
5. **Place New Date
in Column A:**
- The calculated `newDate` is placed in the
next available row in column `A`.
6. **Update
LRDate:**
- `LRDate` is updated to the last date that
was added.
**Function
IsBusinessDay(testDate As Date) As Boolean**
This function
checks whether a given date is a business day.
- **Weekday
Function:** The `Weekday` function returns the day of the week, with `vbMonday`
as the first day of the week.
- **Business Day
Check:** If the day is Monday through Friday (`< 6`), the function returns
`True`, meaning it’s a business day. Otherwise, it returns `False`.
7. **Result:**
The loop continues until all specified rows are filled with the last business date of each quarter.
Comments
Post a Comment