I am trying to generate a table to record articles published each month. However, the months I work with different clients vary based on the campaign length. For example, Client A is on a six month contract from March to September. Client B is on a 12 month contract starting from February.
Rather than creating a bespoke list of the relevant months each time, I want to automatically generate the list based on campaign start and finish.
Here's a screenshot to illustrate how this might look:
Below is an example of expected output from the above, what I would like to achieve:
Currently, the only month that's generated is the last one. And it goes into A6 (I would have hoped A5, but I feel like I'm trying to speak a language using Google Translate, so...).
Here's the code I'm using:
Sub CreateReport()
Dim uniqueMonths As Collection
Set uniqueMonths = New Collection
Dim dateRange As Range
Set dateRange = Range("B2:C2")
On Error Resume Next
Dim currentRange As Range
For Each currentRange In dateRange.Cells
If currentRange.Value <> "" Then
Dim tempDate As Date: tempDate = CDate(currentRange.Text)
Dim parsedDateString As String: parsedDateString = Format(tempDate, "MMM")
uniqueMonths.Add item:=parsedDateString, Key:=parsedDateString
End If
Next currentRange
On Error GoTo 0
Dim uniqueMonth As Variant
For Each uniqueMonth In uniqueMonths
Debug.Print uniqueMonth
Next uniqueMonth
Dim item As Variant, currentRow As Long
currentRow = 5
For Each item In uniqueMonths
dateRange.Cells(currentRow, 0).Value = item
currentRow = currentRow + 1
Next item
End Sub
User defined function via Evaluate
Simply enter =GetCampaignMonths(A2,B2) into cell A5.
If you don't dispose of the newer dynamic versions 2019+/MS365, it's necessary to enter a CSE (Ctrl+Shift+Enter) to finish an {array formula}:
Explanation
Basically this displays all results as dynamic (spill) range, profiting from an evaluation of a code one liner ...
e.g. Jan..Dec (12 months represented by column addresses)*
=TEXT(DATE(0,Column(A:L),1),"mmmm")
If you want to include further years, the udf simply adds the years difference (section a) multiplied by 12 to the column numbers (c.f. section b).
The evaluation of the DATE() function (c.f. section c) gets even successive years correctly, TEXT() returns the (English) months names formatted via "mmmm".
Public Function GetCampaignMonths(StartDate As Date, StopDate As Date)
'Purpose: get vertical 2-dim array of month names
'a) get years difference
Dim yrs As Long: yrs = Year(StopDate) - Year(StartDate)
'b) get column numbers representing months
Dim cols As String
cols = Split(Cells(, month(StartDate)).Address, "$")(1)
cols = cols & ":" & Split(Cells(, month(StopDate) + Abs(yrs * 12)).Address, "$")(1)
'c) evaluate dates
Dim months
months = Evaluate("Text(Date(0,Column(" & cols & "),1),""mmmm"")")
GetCampaignMonths = Application.Transpose(months)
End Function
Make an Array with the month names and then loop trough it accordting to initial month and end month:
Sub test()
Dim IniDate As Date
Dim EndDate As Date
Dim Months As Variant
Dim i As Long
Dim zz As Long
IniDate = CDate(Range("A2").Value)
EndDate = CDate(Range("b2").Value)
Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
zz = 5
For i = Month(IniDate) - 1 To Month(EndDate) - 1 Step 1
Range("A" & zz) = Months(i)
zz = zz + 1
Next i
Erase Months
End Sub
For this code to work, both dates must be recognized as dates properly. Make sure of that or it won't work.
IMPORTANT: This will work only with dates in same year, unfortunately... I noticed that right now.
UPDATE: You can benefit from DateAdd and DateDiff to make a code so it works even in different years :)
DateAdd
function
DateDiff
Function
Sub test2()
Dim IniDate As Date
Dim EndDate As Date
Dim Months As Variant
Dim i As Long
Dim zz As Long
Dim TotalMonths As Byte
IniDate = CDate(Range("A2").Value)
EndDate = CDate(Range("b2").Value)
Months = Array("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
TotalMonths = DateDiff("m", IniDate, EndDate, vbMonday)
zz = 5
For i = 0 To TotalMonths Step 1
Range("A" & zz).Value = Months(Month(DateAdd("m", i, IniDate)) - 1)
zz = zz + 1
Next i
Erase Months
End Sub
You can also do this with functions, no VBA required:
Office 365
A5: =EOMONTH(Campaign_Start,SEQUENCE(1+DATEDIF(Campaign_Start,Campaign_End,"m")+(DAY(Campaign_End)<DAY(Campaign_Start)),,0))
and the results will SPILL down as far as needed.
Format the cells as mmm
If you do not have Office 365, then try:
=EOMONTH(Campaign_Start,-1+ROW(INDEX($A:$A,1):INDEX($A:$A,1+DATEDIF(Campaign_Start,Campaign_End,"m")+(DAY(Campaign_End)<DAY(Campaign_Start)))))
If your version of Excel does not have dynamic arrays where the results SPILL, you will need to enter the formula in the individual cells as an array, and it would require further modification.
As replay to #T.M. nice piece of code. The version using Row Evaluation:
Function GetCampaignMnths(StartDate As Date, StopDate As Date)
'Purpose: get vertical 2-dim array of month names
'b) get rows numbers representing months
Dim monthsNo As Long, rows As String
monthsNo = DateDiff("m", StartDate, StopDate, vbMonday)
rows = Month(StartDate) & ":" & monthsNo + Month(StartDate)
'c) evaluate dates
Dim months
months = Evaluate("Text(Date(0,row(" & rows & "),1),""mmmm"")")
GetCampaignMnths = months
End Function
It can be easily tested using the next sub:
Sub testGetCampaignMohths()
Dim arr
arr = GetCampaignMnths("01.03.2021", "01.08.2022") 'use here date recognized by yor localization. Or build them using DateSerial
Debug.Print Join(Application.Transpose(arr), "|")
End Sub
Assuming A2 & B2 are already dates,
Sub CreateReport()
Dim mth as Date, endmth as Date, orow as Integer
mth = worksheetfunction.eomonth(activesheet.cells(2,1).value,0)
endmth = worksheetfunction.eomonth(activesheet.cells(2,2).value,0)
orow = 5
Do
Activesheet.cells(orow,1).value = worksheetfunction.min(activesheet.cells(2,2).value,mth)
' Activesheet.cells(orow,1).numberformat = "mmm" 'uncomment for automatic formatting
orow = orow + 1
mth = worksheetfunction.eomonth(mth,1)
Loop While mth <= endmth
End Sub
This actually puts dates into your output column which can custom format as "mmm" if necessary. If you decide you actually just want text in those columns then just wrap the min(endmth,mth) in a worksheetfunction.text function with a "mmm" format.
Please, try the next code:
Sub GenerateMonthsL()
Dim sh As Worksheet, firstM As Long, lastM As Long, arrD, arrProj, i As Long, k As Long
Set sh = ActiveSheet
firstM = month(sh.Range("A2").Value2)
lastM = month(sh.Range("B2").Value2)
arrD = Split("Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Dec", ",")
ReDim arrProj(lastM - firstM + 1)
For i = firstM - 1 To lastM - 1
arrProj(k) = arrD(i): k = k + 1
Next
ReDim Preserve arrProj(k - 1)
sh.Range("A5").Resize(UBound(arrProj) + 1, 1).value = Application.Transpose(arrProj)
With sh.Range("A4:B4")
.value = Array("Months", "Articles Published")
.Font.Bold = True
.Interior.Color = 14998742
.EntireColumn.AutoFit
End With
End Sub
If you would rather avoid VBA entirely, Excel's array functions let you do this using spreadsheet formulae (if your version of Excel is recent enough).
Put this formula in Cell A5 (assuming start date in A2, and end date in B2):
=LET(mnths,1+(12*YEAR(B2)+MONTH(B2)-(12*YEAR(A2)+MONTH(A2))),s,SEQUENCE(mnths),TEXT(DATE(YEAR(A2),MONTH(A2)+(s-1),1),"mmm"))
If you have more than a year, you can amend the TEXT format string to "mmm-yy".
Problem
The following [mcve] will output an array of arrays of week numbers between two dates. It works when both dates are on the same year, however, some years have 52 weeks and start within the last days of the last year. And others have 53 weeks.
An example of 52 weeks is the 2020 calendar:
Where the first week begins on Dec 30.
And the example of 53 weeks is the 2016 calendar:
That begins only on Jan 4th.
Code
The following code is commented and outputs an array of arrays with the week numbers.
Sub w_test()
Dim Arr() As Variant, ArrDateW() As Variant
'Initial Date
DateI = DateSerial(2015, 5, 5)
'Final Date
DateF = DateSerial(2017, 9, 20)
'Difference in weeks between DateI and DateF
weekDif = DateDiff("ww", DateI, DateF) + k - 1
i = Weekday(DateI)
d = DateI
'If not Sunday, go back to last week, to start the loop
If i <> 1 Then
d = DateAdd("d", -(i - 1), d)
End If
ReDim ArrDateW(weekDif)
ReDim Arr(2)
'Loop on all weeks between two dates to populate array of arrays
For i = 0 To weekDif
'Date
Arr(0) = d
'Trying to solve problem with New Year
If Application.WorksheetFunction.WeekNum(d) = 53 Then
flag = True
End If
If flag = False Then
Arr(1) = Application.WorksheetFunction.WeekNum(d)
Else
Arr(1) = Application.WorksheetFunction.WeekNum(DateSerial(Year(d) + 1, 1, 1))
flag = False
End If
'Year
Arr(2) = Year(d)
'Populate array of arrays
ArrDateW(i) = Arr
'Next Week Number
d = DateAdd("ww", 1, d)
Next i
'To stop with Ctrl+F8
Debug.Print d
End Sub
Question
2015 had 53 weeks, however the program outputs the following:
And between 2016 and 2017, the output is a mess:
How to fix the program to output these week numbers correctly?
I went about it somewhat differently, relying on built-in VBA functions to correctly calculate the week numbers. Read about ISO week numbers is this answer and see how I'm using the DataPart function -- though you can substitute your own version of Ron de Bruin's ISO week number function if you feel it's warranted.
A couple of quick side notes:
Always use Option Explicit
Try to use more descriptive variable names. YOU know what you're talking about NOW. In a few months, you'll struggle to remember what d and Arr mean (even if it seems obvious now). It's just a good habit and makes the code self-documenting.
My example below breaks the logic into a separate function with an optional parameter (just for fun) that would allow the caller to change the start of the week to a different day.
Code module:
Option Explicit
Sub w_test()
Dim initialDate As Date
Dim finaldate As Date
initialDate = #5/5/2015#
finaldate = #9/29/2017#
Dim weeks As Variant
weeks = WeekNumbers(initialDate, finaldate)
Debug.Print "There are " & UBound(weeks, 1) & " weeks between " & _
Format(initialDate, "dd-mmm-yyyy") & " and " & _
Format(finaldate, "dd-mmm-yyyy")
End Sub
Private Function WeekNumbers(ByVal initialDate As Date, _
ByVal finaldate As Date, _
Optional ByVal weekStart As VbDayOfWeek = vbSunday) As Variant
Dim numberOfWeeks As Long
numberOfWeeks = DateDiff("ww", initialDate, finaldate, weekStart, vbFirstFullWeek)
Dim startOfWeek As Date
If Weekday(initialDate) <> vbSunday Then
Dim adjustBy As Long
If Weekday(initialDate) > weekStart Then
adjustBy = Weekday(initialDate) - weekStart
Else
adjustBy = (Weekday(initialDate) + 7) - weekStart
End If
startOfWeek = DateAdd("d", -adjustBy, initialDate)
End If
Dim allTheWeeks As Variant
ReDim allTheWeeks(1 To numberOfWeeks)
Dim weekInfo As Variant
ReDim weekInfo(1 To 3)
Dim i As Long
For i = 1 To numberOfWeeks
weekInfo(1) = startOfWeek
weekInfo(2) = DatePart("ww", startOfWeek, weekStart, vbFirstFourDays)
weekInfo(3) = Year(startOfWeek)
allTheWeeks(i) = weekInfo
startOfWeek = DateAdd("ww", 1, startOfWeek)
Next i
WeekNumbers = allTheWeeks
End Function
So I have a macro that I only want to run on weekdays. I created the macro that (I'm hoping) will check what day of the week it is and put that into a cell. This is what I have:
Private Sub dayCheck()
If Weekday(Now) = vbMonday Or vbTuesday Or vbWednesday Or vbThursday Or vbFriday Then
Dim BlankRow As Long
BlankRow = Range("A65536").End(xlUp).Row + 1
Cells(BlankRow, 1).Select
Selection.Value = Date
Selection.Offset(0, 1).Value = Time
Selection.Offset(0, 2).Value = WeekdayName(Weekday(Now))
Selection.Offset(0, 3).Value = Environ("Username")
ElseIf Weekday(Now) = vbSaturday Or vbSunday Then
Dim time1, time2
Do
time1 = Weekday(Now)
time2 = vbMonday
Do Until time1 = time2
DoEvents
time1 = Now()
Loop
Loop
End If
Application.OnTime TimeValue("12:00:00"), "dayCheck"
End Sub
My problem is I don't have administrator rights to change the system date. Is there a way I can simulate this through a macro?
You can simulate the date code by formatting the general or number output of the now() function in excel and just add 1 to increment the date. Numbers to the right of the decimal represent the percent of time beyond midnight until the next day.
Today's datetime code is: 43412.37786
Tomorrow is 43413.37786
So your question about testing your code can be answered by creating a for loop with:
Dim Today
Today = Now
For Days = Today To Today + 7 'Tests today through next Thursday.
If Weekday(Days) = ...
Next Days
But Darren's answer looks like it solves your problem, so I'd probably just go with that.
Now gives the date/time, Date gives just the date.
Weekday(Date) returns the current day number of the week with Sunday being 1.
As it's Thursday today Weekday(Now)=vbMonday will return False.
Weekday(Now) = vbMonday Or vbTuesday Or vbWednesday Or vbThursday Or vbFriday returns 7 - I'm not sure why, but it does. The main thing here is it doesn't return TRUE or FALSE.
For that statement to work you'd have to use
Weekday(Now) = vbMonday Or Weekday(Now) = vbTuesday Or Weekday(Now) = vbWednesday Or Weekday(Now) = vbThursday Or Weekday(Now) = vbFriday.
An easier way is Weekday(Date,vbMonday)<=5 - vbMonday numbers the week Monday = 1, Sunday = 7 and it answers the question "Is date a weekday?".
Here's the code:
Sub Test()
'DayCheck Now
'Or
'DayCheck #11/7/2018 6:55:00 PM#
'Or look at next 7 days starting now.
Dim x As Long
Dim StartDate As Date
StartDate = Now
For x = 0 To 6
DayCheck StartDate + x
Next x
End Sub
Sub DayCheck(MyDate As Date)
Dim rLastCell As Range
Dim wrkSht As Worksheet
Set wrkSht = ThisWorkbook.Worksheets("Sheet1")
If Weekday(MyDate, vbMonday) <= 5 Then
Set rLastCell = wrkSht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'Reference to the blank cell itself.
rLastCell.Resize(, 4) = Array(MyDate, MyDate, MyDate, Environ("Username"))
rLastCell.NumberFormat = "dd-mmm-yy"
rLastCell.Offset(, 1).NumberFormat = "hh:mm AM/PM"
rLastCell.Offset(, 2).NumberFormat = "dddd"
Else 'No need to check if it's a weekend - we know it's not a weekday.
'Just keep running until time1 = 2 and time2 = 2?
'I guess that'll be Midnight on Monday?
End If
End Sub
Note I'm putting the same value in columns A:C - just the date and time.
I then format each cell to show the part of the date & time you're interested in.
Below code hide a certain number of rows(depending on the number of the week we are in) and shows only the cell corresponding to the current week number and cells corresponding to the future week numbers.
Dim test As String
test = Format(Now, "yyyy", vbMonday) & KW(Now)
For k = 3 To lastColumn
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).ColumnWidth = cWidth
If ThisWorkbook.Worksheets(PlanningTableNameUG).Cells(1, k).Value = test Then
today = True
On Error Resume Next
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k - 1).Ungroup
On Error GoTo 0
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k - 1).Group
End If
If Not today Then
On Error Resume Next
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Ungroup
On Error GoTo 0
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Group
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Hidden = True
If Hidden = True Then
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Group.Copy
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Group.Insert Shift:=xlToRight
End If
Else
ThisWorkbook.Worksheets(PlanningTableNameUG).Columns(k).Hidden = False
End If
Next k
' calculate the week number
Function KW(d As Date) As Integer
Dim Tag As Long
Tag = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1)
KW = (d - Tag - 3 + (Weekday(Tag) + 1) Mod 7) \ 7 + 1
End Function
Now, I need to count how many columns were hidden and add the exact numbers of columns, example:
columns:
1,2,3,4,5,6,7,8,9,10 (column 4 is corresponding to today week number)
I hide: 1,2,3 because there are in the past weeks, and want to add 11,12, 13, together with the week number corresponding for them, but not more than 1 year from current date.
Count of the weeks starts at the begging of the current year.
When hiding the columns you could add an integer variable that increases by one then use this variable to add that many new columns.
Then to add the week number, use the last column with the week number on it and add one to it for each of the new columns...
To count hidden columns in used range of ThisWorkbook.Worksheets(PlanningTableNameUG):
Dim col As Range
Dim cnt As Long
For Each col In ThisWorkbook.Worksheets(PlanningTableNameUG).UsedRange
Debug.Print col.EntireColumn.Hidden
cnt = cnt - col.EntireColumn.Hidden
Next col
EntireColumn.Hidden returns True if is hidden. True is -1 in VBA, that is why i deduct it from the counter to get positive value.
I have a row of trading dates, stored in Column A. It contains trading days and hence, it doesn't contain all the days in a year. I would like to get a particular date and remove one year from it. I would like to find the index of the newdate cell within the same column. If not possible I would like to find the next closest date.
What I have tried so far:
Dim date1 As Double
date1 = Sheets("Part2").Cells(i, 1).Value
Dim matchRow As Integer
matchRow = 3
While Sheets("1.A").Cells(matchRow, 1).Value <> date1
matchRow = matchRow + 1
Wend
I am able to get a particular date in sheet but now I need to get the date one year before that, if not next nearest date after that.
Need some guidance on doing this.
Also tried:
Sheets("Part2").Cells(i, 1).Value -365. It is not working..
Use DateAdd:
DateAdd("yyyy",-1,Sheets("Part2").Cells(i, 1).Value)
UPD since your dates are stored as text in format "yyyymmdd" and starts from row №3, use this one:
Dim date1 As Date
Dim srtDate1 As String, srtDate2 As String
Dim matchRow
strDate1 = Sheets("Part2").Cells(i, 1).Value
date1 = DateSerial(Left(strDate1, 4), Mid(strDate1, 3, 2), Right(strDate1, 2))
srtDate2 = Format(DateAdd("yyyy", -1, date1), "yyyymmdd")
matchRow = Application.Match(CDbl(srtDate2), Sheets("Part2").Range("A:A"), 1)
If IsError(matchRow) Then
matchRow = 3
Else
matchRow = matchRow + 1
End If
MsgBox "new date: " & Sheets("Part2").Range("A" & matchRow)