There are a few things you can do in your coding to improve both the logic and the organization of your application. Your code does work and kudos for already using a memory-based array to speed up the processing of (partially) filling out your date axis. My suggestion solution below does not use Collections, but creates a two-dimensional array for reasons I'll explain.
As a general rule, I try and avoid merging cells whenever possible. It causes many problems for the user, as well as for writing code. The solution is to Center Across Selection. Because the solution below is based on that concept, the memory-based array can now be created with two dimensions: three rows and N columns. The first two rows will contain many empty cells, which we'll use to our advantage in formatting later.
The next point to make is that I try to separate the logic for creating a data set (or range in this case) from the logic to format the range. If you're careful about it, you can more easily change either how you create the data OR how you format the data without affecting the other. That's the goal anyway. It doesn't always work out quite that cleanly, but it's a philosophy that I attempt to apply whenever I can.
I've done quite a bit of work with the idea of "working days". Long ago, I started using Craig Pearson's post for a Better NetworkDays function. I've included that module below with an added function to determine if a given date IsAWorkDay.
I also try to consistently create an array of holidays to increase the accuracy of whatever calendar calculations I'm making. In the example below, I have created a function to return an array of holidays. This example is hard-coded, but in practice I most often create a table on a (possibly hidden) worksheet. That makes it far easier to update the list of holidays without changing the code.
The second-to-last item to note are to avoid the use of "magic numbers". While you may think your time axis rows will never change -- never say never :)
And my last item is that my usual practice is to create a routine that is based on a Range to use parameters as inputs. This way, I can change where the range will go, i.e. a different sheet or starting in a different column, without re-coding the meat of the logic.
Here is an example module showing code to illustrate the points above:
Option Explicit
Private Const MONTH_ROW As Long = 1
Private Const WEEK_ROW As Long = 2
Private Const DATE_ROW As Long = 3
Sub test()
With Sheet1
'--- clear for testing
.Range("firstday").Offset(-2, 0).Resize(3, 500).Clear
Dim axisRange As Range
Set axisRange = CreateTimeAxis(.Range("firstday"), #3/25/2020#, #7/31/2020#)
FormatTimeAxis axisRange
End With
End Sub
Function CreateTimeAxis(ByRef timeAxisAnchor As Range, _
ByVal start As Date, _
ByVal finish As Date) As Range
'--- make sure we account for any company holidays
Dim holidays As Variant
holidays = GetCompanyHolidays()
Dim startMinus10 As Date
Dim firstMonday As Date
Dim lastFriday As Date
Dim totalWorkingDays As Long
startMinus10 = DateAdd("D", -10, start)
firstMonday = startMinus10 - (Weekday(startMinus10, vbMonday) - 1)
lastFriday = DateAdd("D", 19 - Weekday(finish, vbMonday), finish)
totalWorkingDays = NetWorkdays2(firstMonday, lastFriday, Saturday + Sunday, holidays)
'--- create three "time" rows:
' top row is months
' middle row is week number
' bottom row is working date
Dim timeaxis As Variant
ReDim timeaxis(1 To 3, 1 To totalWorkingDays)
Dim axisDate As Date
Dim previousMonth As Long
Dim previousWeek As Long
Dim i As Long
i = 1
For axisDate = firstMonday To lastFriday
If IsAWorkDay(axisDate, holidays) Then
'--- if this is a new month, this cell notes the first of the month
If previousMonth <> Month(axisDate) Then
timeaxis(MONTH_ROW, i) = DateSerial(Year(axisDate), Month(axisDate), 1)
previousMonth = Month(axisDate)
End If
'--- if this is a new week number, this cell notes the new week number
If previousWeek <> WorksheetFunction.IsoWeekNum(axisDate) Then
previousWeek = WorksheetFunction.IsoWeekNum(axisDate)
timeaxis(WEEK_ROW, i) = previousWeek
End If
'--- each cell on row 3 always gets a date
timeaxis(DATE_ROW, i) = axisDate
i = i + 1
End If
Next axisDate
'--- copy the time axis to the worksheet at the given range anchor
Dim axisRange As Range
Set axisRange = timeAxisAnchor.Offset(-2, 0).Resize(3, totalWorkingDays)
axisRange.Value = timeaxis
Set CreateTimeAxis = axisRange
End Function
Sub FormatTimeAxis(ByRef axisRange As Range)
Application.ScreenUpdating = False
'--- NOTE: the anchor cell may not be in column 1
With axisRange
'--- all rows
.Font.Name = "Calibri"
'--- month row
.Rows(1).Font.Size = 16
Dim i As Long
Dim firstCol As Long
firstCol = -1
For i = 0 To (.Columns.Count - 1)
If Not IsEmpty(.Offset(0, i).Cells(MONTH_ROW, 1)) Then
If firstCol = -1 Then
firstCol = i
Else
.Offset(0, firstCol).Resize(1, i - firstCol).Select
Selection.HorizontalAlignment = xlCenterAcrossSelection
Selection.NumberFormat = "mmm-yyyy"
firstCol = i
End If
End If
Next i
'--- still (probably) need to center the last month
.Offset(MONTH_ROW - 1, firstCol).Resize(1, i - firstCol).Select
Selection.HorizontalAlignment = xlCenterAcrossSelection
Selection.NumberFormat = "mmm-yyyy"
'--- week row
.Rows(2).Font.Size = 16
firstCol = -1
For i = 0 To (.Columns.Count - 1)
If Not IsEmpty(.Offset(0, i).Cells(WEEK_ROW, 1)) Then
If firstCol = -1 Then
firstCol = i
Else
.Offset(1, firstCol).Resize(1, i - firstCol).Select
Selection.HorizontalAlignment = xlCenterAcrossSelection
Selection.NumberFormat = "00"
End If
End If
Next i
'--- still (probably) need to center the last month
.Offset(WEEK_ROW - 1, firstCol).Resize(1, i - firstCol).Select
Selection.HorizontalAlignment = xlCenterAcrossSelection
Selection.NumberFormat = "00"
'--- working date row
With .Rows(DATE_ROW)
.Orientation = 90
.Font.Name = "Calibri"
.Font.Size = 10
.Font.Bold = False
.NumberFormat = "dd/mm/yyyy"
.RowHeight = 60#
End With
End With
Application.ScreenUpdating = True
End Sub
Private Function GetCompanyHolidays() As Variant
'--- holidays are hard-coded here, or can be listed on a worksheet and
' converted to the returned array (preferred)
Dim theList As String
theList = "1-Jan-2020,12-Apr-2020,13-Apr-2020,1-May-2020," & _
"8-May-2020,21-May-2020,1-Jun-2020,14-Jul-2020,15-Aug-2020," & _
"1-Nov-2020,11-Nov-2020,25-Dec-2020"
Dim holidayList As Variant
holidayList = Split(theList, ",")
Dim dateArray As Variant
ReDim dateArray(1 To UBound(holidayList) + 1)
Dim i As Long
For i = 1 To UBound(dateArray)
dateArray(i) = CDate(holidayList(i - 1))
Next i
GetCompanyHolidays = dateArray
End Function
This is the CalendarSupport module:
'@Folder("Libraries")
Option Explicit
Option Compare Text
'--- from: http://www.cpearson.com/excel/betternetworkdays.aspx
'''''''''''''''''''''''''''''''''''''''''''''''''''''
' EDaysOfWeek
' Days of the week to exclude. This is a bit-field
' enum, so that its values can be added or OR'd
' together to specify more than one day. E.g,.
' to exclude Tuesday and Saturday, use
' (Tuesday+Saturday), or (Tuesday OR Saturday)
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Enum EDaysOfWeek
Sunday = 1 ' 2 ^ (vbSunday - 1)
Monday = 2 ' 2 ^ (vbMonday - 1)
Tuesday = 4 ' 2 ^ (vbTuesday - 1)
Wednesday = 8 ' 2 ^ (vbWednesday - 1)
Thursday = 16 ' 2 ^ (vbThursday - 1)
Friday = 32 ' 2 ^ (vbFriday - 1)
Saturday = 64 ' 2 ^ (vbSaturday - 1)
End Enum
Public Function IsAWorkDay(ByRef thisDay As Date, Optional ByRef holidays As Variant) As Boolean
If IsMissing(holidays) Then
IsAWorkDay = (Workday2(thisDay - 1, 1, Sunday + Saturday) = thisDay)
Else
IsAWorkDay = (Workday2(thisDay - 1, 1, Sunday + Saturday, holidays) = thisDay)
End If
End Function
Public Function NetWorkdays2(ByVal StartDate As Date, _
ByVal EndDate As Date, _
ByVal ExcludeDaysOfWeek As Long, _
Optional ByRef holidays As Variant) As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NetWorkdays2
' This function calcluates the number of days between StartDate and EndDate
' excluding those days of the week specified by ExcludeDaysOfWeek and
' optionally excluding dates in Holidays. ExcludeDaysOfWeek is a
' value from the table below.
' 1 = Sunday = 2 ^ (vbSunday - 1)
' 2 = Monday = 2 ^ (vbMonday - 1)
' 4 = Tuesday = 2 ^ (vbTuesday - 1)
' 8 = Wednesday = 2 ^ (vbWednesday - 1)
' 16 = Thursday = 2 ^ (vbThursday - 1)
' 32 = Friday = 2 ^ (vbFriday - 1)
' 64 = Saturday = 2 ^ (vbSaturday - 1)
' To exclude multiple days, add the values in the table together. For example,
' to exclude Mondays and Wednesdays, set ExcludeDaysOfWeek to 10 = 8 + 2 =
' Monday + Wednesday.
' If StartDate is less than or equal to EndDate, the result is positive. If
' StartDate is greater than EndDate, the result is negative. If either
' StartDate or EndDate is less than or equal to 0, the result is a
' #NUM error. If ExcludeDaysOfWeek is less than 0 or greater than or
' equal to 127 (all days excluded), the result is a #NUM error.
' Holidays is optional and may be a single constant value, an array of values,
' or a worksheet range of cells.
' This function can be used as a replacement for the NETWORKDAYS worksheet
' function. With NETWORKDAYS, the excluded days of week are hard coded
' as Saturday and Sunday. You cannot exlcude other days of the week. This
' function allows you to exclude any number of days of the week (with the
' exception of excluding all days of week), from 0 to 6 days. If
' ExcludeDaysOfWeek = 65 (Sunday + Saturday), the result is the same as
' NETWORKDAYS.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim TestDayOfWeek As Long
Dim TestDate As Date
Dim Count As Long
Dim Stp As Long
Dim Holiday As Variant
Dim Exclude As Boolean
If ExcludeDaysOfWeek < 0 Or ExcludeDaysOfWeek >= 127 Then
' invalid value for ExcludeDaysOfWeek. get out with error.
NetWorkdays2 = CVErr(xlErrNum)
Exit Function
End If
If StartDate <= 0 Or EndDate <= 0 Then
' invalid date. get out with error.
NetWorkdays2 = CVErr(xlErrNum)
Exit Function
End If
' set the value used for the Step in
' the For loop.
If StartDate <= EndDate Then
Stp = 1
Else
Stp = -1
End If
For TestDate = StartDate To EndDate Step Stp
' get the bit pattern of the weekday of TestDate
TestDayOfWeek = 2 ^ (Weekday(TestDate, vbSunday) - 1)
If (TestDayOfWeek And ExcludeDaysOfWeek) = 0 Then
' do not exclude this day of week
If IsMissing(holidays) = True Then
' count day
Count = Count + 1
Else
Exclude = False
' holidays provided. test date for holiday.
If IsObject(holidays) = True Then
' assume Excel.Range
For Each Holiday In holidays
If Holiday.Value = TestDate Then
Exclude = True
Exit For
End If
Next Holiday
Else
' not an Excel.Range
If IsArray(holidays) = True Then
For Each Holiday In holidays
If Int(Holiday) = TestDate Then
Exclude = True
Exit For
End If
Next Holiday
Else
' not an array or range, assume single value
If TestDate = holidays Then
Exclude = True
End If
End If
End If
If Exclude = False Then
Count = Count + 1
End If
End If
Else
' excluded day of week. do nothing
End If
Next TestDate
' return the result, positive or negative based on Stp.
NetWorkdays2 = Count * Stp
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Workday2
' This is a replacement for the ATP WORKDAY function. It
' expands on WORKDAY by allowing you to specify any number
' of days of the week to exclude.
' StartDate The date on which the period starts.
' DaysRequired The number of workdays to include
' in the period.
' ExcludeDOW The sum of the values in EDaysOfWeek
' to exclude. E..g, to exclude Tuesday
' and Saturday, pass Tuesday+Saturday in
' this parameter.
' Holidays an array or range of dates to exclude
' from the period.
' RESULT: A date that is DaysRequired past
' StartDate, excluding holidays and
' excluded days of the week.
' Because it is possible that combinations of holidays and
' excluded days of the week could make an end date impossible
' to determine (e.g., exclude all days of the week), the latest
' date that will be calculated is StartDate + (10 * DaysRequired).
' This limit is controlled by the RunawayLoopControl variable.
' If DaysRequired is less than zero, the result is #VALUE. If
' the RunawayLoopControl value is exceeded, the result is #VALUE.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function Workday2(ByVal StartDate As Date, _
ByVal DaysRequired As Long, _
ByVal ExcludeDOW As EDaysOfWeek, _
Optional ByRef holidays As Variant) As Variant
Dim N As Long ' generic counter
Dim C As Long ' days actually worked
Dim TestDate As Date ' incrementing date
Dim HNdx As Long ' holidays index
Dim CurDOW As EDaysOfWeek ' day of week of TestDate
Dim IsHoliday As Boolean ' is TestDate a holiday?
Dim RunawayLoopControl As Long ' prevent infinite looping
Dim V As Variant ' For Each loop variable for Holidays.
If DaysRequired < 0 Then
' day required must be greater than or equal
' to zero.
Workday2 = CVErr(xlErrValue)
Exit Function
ElseIf DaysRequired = 0 Then
Workday2 = StartDate
Exit Function
End If
If ExcludeDOW >= (Sunday + Monday + Tuesday + Wednesday + _
Thursday + Friday + Saturday) Then
' all days of week excluded. get out with error.
Workday2 = CVErr(xlErrValue)
Exit Function
End If
' this prevents an infinite loop which is possible
' under certain circumstances.
RunawayLoopControl = DaysRequired * 10000
N = 0
C = 0
' loop until the number of actual days worked (C)
' is equal to the specified DaysRequired.
Do Until C = DaysRequired
N = N + 1
TestDate = StartDate + N
CurDOW = 2 ^ (Weekday(TestDate) - 1)
If (CurDOW And ExcludeDOW) = 0 Then
' not excluded day of week. continue.
IsHoliday = False
' test for holidays
If IsMissing(holidays) = False Then
For Each V In holidays
If V = TestDate Then
IsHoliday = True
' TestDate is a holiday. get out and
' don't count it.
Exit For
End If
Next V
End If
If IsHoliday = False Then
' TestDate is not a holiday. Include the date.
C = C + 1
End If
End If
If N > RunawayLoopControl Then
' out of control loop. get out with #VALUE
Workday2 = CVErr(xlErrValue)
Exit Function
End If
Loop
' return the result
Workday2 = StartDate + N
End Function
