4
\$\begingroup\$

I made the bellow macro to create a time line in excel.

It shows the working days, the week numbers and the month together with the year.

First I start with projectstart date and projectend date. As these dates can be any working day and I want my timeline to start on a monday and end on a friday, I find the firstmonday (minus 10 days to give some clearance) and the lastfriday (plus two weeks)

I then create an Array containing all the working days in the interval. A collection with the months (mmm-yyyy) and a collection with the number of working days in these months

And then I copy the workday range to excel on one line, the week numbers on the line above and the month-year on the line above.

Even though it's working, I feel my code is quite messy and that there must be a much better way to do this. Especially the part for the months/year were I create 2 collections in a rather complicated logic and the way I transfer that on my worksheet. So I'd like to simplify this code as much as possible and maybe improve it's performance as it will run every time the starting/ending dates of the project are changing.

I tried to make it operational for anyone to test it. All you have to do it name a cell as 'firstday' on the third row of an empty worksheet, resize that row height to 60, resize all the columns width to 2 for better readabylity and run the code.

Option Explicit

Sub timeaxis()
'create days, weeks, months and years axis + vertical lines and redim the gantt chart area
Dim startminus10 As Date, firstmonday As Date, lastfriday As Date, nbofworkdays As Long, axisday() As Date, axismonth As New Collection, axismonthlenght As New Collection
Dim projectstart As Date
Dim projectend As Date
Dim rngday1 As Range
Set rngday1 = Range("firstday")
projectstart = "25/03/2020"
projectend = "31/07/2020"


Dim n As Long
startminus10 = DateAdd("D", -10, projectstart)
firstmonday = startminus10 - (Weekday(startminus10, vbMonday) - 1)
lastfriday = DateAdd("D", 19 - Weekday(projectend, vbMonday), projectend)
nbofworkdays = WorksheetFunction.NetworkDays(firstmonday, lastfriday)
Dim counter As Long
counter = 0

'''''Create timeaxis'''''
    ReDim axisday(nbofworkdays - 1)
    For n = 0 To nbofworkdays - 1
        counter = counter + 1
        axisday(n) = WorksheetFunction.WorkDay(firstmonday, n)
        If n = 0 Then
            axismonth.Add MonthName(DatePart("m", axisday(n))) & " - " & DatePart("yyyy", axisday(n))
            counter = 0
        ElseIf n = nbofworkdays - 1 Then
            axismonthlenght.Add counter + 1
        ElseIf MonthName(DatePart("m", axisday(n))) & " - " & DatePart("yyyy", axisday(n)) = axismonth(axismonth.Count) Then
        'do nothing
        Else
            axismonth.Add MonthName(DatePart("m", axisday(n))) & " - " & DatePart("yyyy", axisday(n))
            axismonthlenght.Add counter
            counter = 0
        End If
    Next
'days
    With Range(rngday1, rngday1.Offset(0, nbofworkdays - 1))
        .Value = axisday
        .Orientation = 90
        .Font.Name = "Calibri"
        .Font.Size = 10
        .Font.Bold = False
        .NumberFormat = "dd/mm/yyyy"
    End With
'weeks
    n = 0
    For n = 0 To (nbofworkdays / 5) - 1
        With Range(rngday1.Offset(-1, n * 5), rngday1.Offset(-1, (n + 1) * 5 - 1))
            .MergeCells = True
            .Font.Name = "Calibri"
            .Font.Size = 16
            .Font.Bold = True
            .Font.ThemeColor = xlThemeColorLight1
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .NumberFormat = "General"
            .Value = DatePart("ww", axisday(n * 5 + 1), vbMonday, vbFirstFourDays)
        End With
    Next
'month/year
    With Range(rngday1.Offset(-2, 0), rngday1.Offset(-2, axismonthlenght(1) - 1))
        .MergeCells = True
        .Value = axismonth(1)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders(xlEdgeRight).ColorIndex = xlAutomatic
    End With
    n = 2
    Dim offsetleft As Long
    Dim offsetright As Long
    offsetleft = 0
    offsetright = 0
    For n = 2 To axismonth.Count
        offsetleft = offsetleft + axismonthlenght(n - 1)
        offsetright = offsetleft + axismonthlenght(n) - 1
        With Range(rngday1.Offset(-2, offsetleft), rngday1.Offset(-2, offsetright))
            .MergeCells = True
            .Value = axismonth(n)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
        End With
    Next
End Sub
\$\endgroup\$
3
\$\begingroup\$

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
| improve this answer | |
\$\endgroup\$
  • \$\begingroup\$ Thank you for taking the time. I really like how you managed to replace my use of the collections by the 2 dimensional array as well as the "Center Across Selection" in order to avoid merging cells. Plus it must be more performant. I will definitly implement these. Regarding the holidays, I want to keep them in my time line but I can still use the logic in the "Format" part of the code to grey them out. I will take the time to thoroughly go through it tomorrow and come back here once I'm done! \$\endgroup\$ – remyfra May 26 at 17:39
0
\$\begingroup\$

This is an answer based on @PeterT 's answer.

So I kept the main logic of your code :

  • No merging of cells but center across selection
  • A 2 dimensional array
  • Keep Data and formatting separate
  • Removing magic numbers

And I changed a few things :

  • removed all .select
  • I noticed that if I apply "xlCenterAcrossSelection" on the whole row it gives the same result
  • -

And I came up with the following code :

Option Explicit

Sub CreateTimeAxis()

    Application.ScreenUpdating = False

Const MONTH_ROW As Long = 1
Const WEEK_ROW As Long = 2
Const DATE_ROW As Long = 3
Const AXIS_ROWS As Long = 3
Const StartClearance As Long = 10 'Calendar days
Const FinnishClearance As Long = 19 '2x7 (two weeks) + 5 (Totalworkdays in a week)
Const Saturday As Long = 6
Const Friday As Long = 5

'---only for testing
    'Otherwise these are module private variables defined in the main Sub
    Range("firstday").Offset(-2, 0).Resize(3, 500).Clear
    Dim day1 As Range
    Set day1 = Range("firstday")
    Dim projectstart As Date
    Dim projectend As Date
    projectstart = "25/03/2020"
    projectend = "31/07/2020"

'--- Compute array and copy to worksheet
    Dim startminus10 As Date
    Dim firstmonday As Date
    Dim lastfriday As Date
    Dim totalWorkingDays As Long
    startminus10 = DateAdd("D", -StartClearance, projectstart)
    firstmonday = startminus10 - (Weekday(startminus10, vbMonday) - 1)
    lastfriday = DateAdd("D", FinnishClearance - Weekday(projectend, vbMonday), projectend)
    totalWorkingDays = WorksheetFunction.NetworkDays(firstmonday, lastfriday)


    '--- 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 AXIS_ROWS, 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 Weekday(axisDate, vbMonday) < Saturday 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.WeekNum(axisDate) Then
                timeaxis(WEEK_ROW, i) = WorksheetFunction.WeekNum(axisDate)
                previousWeek = timeaxis(WEEK_ROW, i)
            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 = day1.Offset(1 - AXIS_ROWS, 0).Resize(AXIS_ROWS, totalWorkingDays)
    axisRange.Value = timeaxis

'--- Format axis
    With axisRange
        With .Rows(MONTH_ROW)
            .Font.Name = "Calibri"
            .Font.Size = 16
            .HorizontalAlignment = xlCenterAcrossSelection
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
            .Borders(xlInsideVertical).ColorIndex = xlAutomatic
            .NumberFormat = "mmm-yyyy"
        End With
        With .Rows(WEEK_ROW)
            .Font.Name = "Calibri"
            .Font.Size = 16
            .Font.Bold = True
            .HorizontalAlignment = xlCenterAcrossSelection
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
            .Borders(xlInsideVertical).ColorIndex = xlAutomatic
        End With
        With .Rows(DATE_ROW)
            .Orientation = 90
            .Font.Size = 10
            .NumberFormat = "dd/mm/yyyy"
            .RowHeight = 60#
            .ColumnWidth = 2#
            .HorizontalAlignment = xlCenter
        End With
    End With
    '--- Borders on DATE_ROW
    For i = 1 To UBound(timeaxis, 2)
        If Weekday(timeaxis(DATE_ROW, i), vbMonday) = Friday Then
            axisRange(DATE_ROW, i).Borders(xlEdgeRight).ColorIndex = xlAutomatic
        End If
    Next

    Application.ScreenUpdating = True
End Sub

I'm a bit stubborn as I didn't make a routine with parameters as inputs but I think it is not really different as my input are public and defined in the main Sub. Also I kept the native VBA WorkDay / NetWorkDay functions at least for now. But I saved the one you shared for later use if needed

Overall I'm quite happy with the result. It's much cleaner and runs about 4 times faster than my original code. Thanks to you!

| improve this answer | |
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.