Using Excel and VBA, I want to autofill a calendar with start and end date

Question

I've been trying to do this for a while but I feel my VBA skills just aren't up to scratch or I'm missing something super obvious. I've spent a few hours trying to fix this myself and haven't found anything efficient. It's all overly complicated and I can't code the VBA correctly.

What I was attempting to do was VLOOKUP the date and use that as the starting point, then use a function to fill all the days (missing weekends and other bank holidays) with the tag Cells contents so that is shown up on the schedule.

But I can't work out how to do this:

I would like to be able to change the start and end dates and have the calendar auto fill, seeing as this calendar is a year and a half long I'd like not to have to do it manually.

Thanks for any help anyone is willing to offer.

Right Thank you Tony for your brilliant answer, although it still left me with the problem I was more than able to adapt and create this code to solve my problem.

Sub fillCalendar()

Dim StartDate As Long
Dim finishDate As Long
Dim daystotal As Long
Dim counter As Integer
counter = 0

'start date is 02/01/2016 / 42371

StartDate = ActiveCell.Value
ActiveCell.Offset(0, 1).Activate
finishDate = ActiveCell.Value
daystotal = finishDate - StartDate
ActiveCell.Offset(0, 2).Activate
Selection.Copy

ActiveCell.Offset(0, StartDate - 42371).Select

While counter <= daystotal
If Worksheets("Schedule").Cells(3, ActiveCell.Column) <> "S" Then

    counter = counter + 1
    Worksheets("Schedule").Paste
    ActiveCell.Offset(0, 1).Activate
Else
    counter = counter + 1
    ActiveCell.Offset(0, 1).Activate
End If
Wend



End Sub

This very simple code will check each column to see if it is a weekday or not. If so it will paste the contents of the TAG cell and move along, adding one to the counter. When the counter meets the totaldays count, the while loop exits leaving a populated calendar. Thanks for everyone's help

Answer 1

This is not a direct answer to your question. However, it provides a macro which I believe you will find useful and which demonstrates the techniques you need for the macro you seek.

Before I could do anything with your question, I need some test data. I manually created this worksheet:

I have reduced the size of columns A to F so I could get more on the screen without it being too small. My colours and formatting is probably not identical to yours but, as I will explain later, this does not matter.

The only different that does matter is the title for the month which I have changed from “January” to “January 2016”. I assume “January” is a string. On my worksheet this is the date “1 January 2016” formatted to display as “January 2016”. I could have formatted it as “January” but I wanted to make this change obvious since my macro depends on it.

Getting this January formatted consistently was enough bother. I did not want to have to do the same for February and March. I assume you find adding the headings for an extra month a chore. So I wrote a macro to add a new month to the right of any existing months.

Run the macro once and you get:

Run it again and you get:

Getting my macro working took long enough so I have not thought about the macro you seek. However, I am sure my macro demonstrates all the techniques you need.

I only use one range because my macro mainly works with individual cells. However, it shows how to create a range, merge the cells within it and format the merged cell.

I said it did not matter that my formatting is slightly different from yours. My macro formats the new month by copying the formats from the previous month. The macro would be faster if I included Application.ScreenUpdating = False but this is a demonstration macro. Once you have finished studying it, delete the diagnostic statements and add Application.ScreenUpdating = False .

I use functions, such as DateSerial and DateDiff , to calculate values I need. When I was learning VBA, I opened VBA Help and worked down the lists of statements, methods and functions. If something looked useful to me, I would read the text carefully. If it did not look useful, I would read enough to know it was there in case my needs changed. For example, there are a number of exotic financial functions which were of no value to me but I knew there were there if my needs changed. There is a function that calculates the number of working days between two dates which may be useful to you.

Work down my macro. I do not explain the individual VBA statements because they are easy to look up once you know they exist. However, I explain the objective of each block of code. For your macro, you need to copy the value and colours from the Tag cell to appropriate cells to the right. My macro calculates the column number for particular dates and for the last Sunday of the previous month. My macro copies values and formats from one cell to another. These are the techniques you need. Come back with questions as necessary but I believe careful study of my macro will give you all the information you need.

Option Explicit

  ' Constants are a convenient way of defining important values:
  '  * If the value changes, one amendment here and the macro(s) that use the
  '    value are immediately updated.
  '  * It makes the code easier to read because "magic numbers" are replaced by
  '    meaningful names.
  Const ColDateStart As Long = 5        ' 5 = Column E
  Const ColDateEnd As Long = 6          ' 6 = Column F
  Const ColDateTag As Long = 8          ' 8 = Column H
  Const ColFirstDay As Long = 9         ' 9 = Column I
  Const RowMonth As Long = 1            ' Row for month names
  Const RowDow As Long = 2              ' Row for days of week as initial letters
  Const RowDom As Long = 3              ' Row for days of month as numbers
  Const RowDataFirst As Long = 4
  Const WshtName As String = "Calendar" ' Amend for your name for the worksheet
Sub AddExtraMonth()

  Dim BorderDayLeftColor As Long
  Dim BorderDayLeftLineStyle As Long
  Dim BorderDayLeftWeight As Long
  Dim BorderMonthRightColor As Long
  Dim BorderMonthRightLineStyle As Long
  Dim BorderMonthRightWeight As Long
  Dim ColCrnt As Long
  Dim ColEndNewMonth As Long
  Dim ColStartNewMonth As Long
  Dim ColLastRowMonth As Long
  Dim ColOffset As Long
  Dim ColSunday As Long
  Dim ColSource As Long
  Dim Dom As Long
  Dim DowMonthNewStart As Long
  Dim FontColor As Long
  Dim InteriorColor As Long
  Dim MonthCrntLast As Date
  Dim MonthNewEnd As Date
  Dim MonthNewStart As Date
  Dim NumDaysNewMonth As Long
  Dim NumberFormat As String
  Dim Pattern As Long
  Dim PatternColorIndex As Long
  Dim RngRowMonththNew As Range
  Dim RowCrnt As Long
  Dim RowLast As Long

  With Sheets(WshtName)

    ' Get useful column and row numbers
    ColLastRowMonth = .Cells(RowMonth, Columns.Count).End(xlToLeft).Column
    ColStartNewMonth = .Cells(RowDow, Columns.Count).End(xlToLeft).Column + 1
    RowLast = .Cells(Rows.Count, ColDateStart).End(xlUp).Row

    Debug.Print "ColLastRowMonth " & ColLastRowMonth
    Debug.Print "ColStartNewMonth " & ColStartNewMonth
    Debug.Print "RowLast " & RowLast

    ' Get last current month. Calculate first and last day of new month
    MonthCrntLast = .Cells(RowMonth, ColLastRowMonth)  ' Last value in row RowMonth is current last month
    MonthNewStart = DateSerial(Year(MonthCrntLast), Month(MonthCrntLast) + 1, 1)
    MonthNewEnd = DateSerial(Year(MonthNewStart), Month(MonthNewStart) + 1, 0)

    Debug.Print "MonthCrntLast " & Format(MonthCrntLast, "ddd d mmm yy")
    Debug.Print "MonthNewStart " & Format(MonthNewStart, "ddd d mmm yy")
    Debug.Print "MonthNewEnd " & Format(MonthNewEnd, "ddd d mmm yy")

    ' Calculate column of last sunday of current last month
    DowMonthNewStart = Weekday(MonthNewStart)
    ColSunday = ColStartNewMonth - DowMonthNewStart + 1

    Debug.Print "DowMonthNewStart " & DowMonthNewStart
    Debug.Print "ColSunday " & ColSunday & " = " & ColNumToCode(ColSunday)

    ' Calculate number of days in new month.
    ' Calcutate last column of new month
    NumDaysNewMonth = DateDiff("d", MonthNewStart, MonthNewEnd) + 1
    ColEndNewMonth = ColStartNewMonth + NumDaysNewMonth - 1

    Debug.Print "NumDaysNewMonth " & NumDaysNewMonth
    Debug.Print "ColStartNewMonth " & ColStartNewMonth & " = " & ColNumToCode(ColStartNewMonth)
    Debug.Print "ColEndNewMonth " & ColEndNewMonth & " = " & ColNumToCode(ColEndNewMonth)

    ' Calulate range for new month within row RowMonth
    Set RngRowMonththNew = .Range(.Cells(RowMonth, ColStartNewMonth), .Cells(RowMonth, ColEndNewMonth))

    Debug.Print "RngRowMonththNew " & Replace(RngRowMonththNew.Address, "$", "")

    ' Size new columns to match columns from previous month
    RngRowMonththNew.Columns.ColumnWidth = .Cells(RowMonth, ColStartNewMonth - 2).ColumnWidth

    ' Get formats from previous month
    With .Cells(RowMonth, ColLastRowMonth)
      FontColor = .Font.Color
      InteriorColor = .Interior.Color
      NumberFormat = .NumberFormat
    End With

    With .Cells(RowDow, ColStartNewMonth - 1)
      ' Note these value are not used until the end
      BorderMonthRightLineStyle = .Borders(xlEdgeRight).LineStyle
      BorderMonthRightWeight = .Borders(xlEdgeRight).Weight
      BorderMonthRightColor = .Borders(xlEdgeRight).Color
    End With

    ' Merge and format cells to contain month name
    RngRowMonththNew.Merge
    With .Cells(RowMonth, ColStartNewMonth)
      .Value = MonthNewStart
      .NumberFormat = NumberFormat
      .HorizontalAlignment = xlCenter
      .Font.Color = FontColor
      .Interior.Color = InteriorColor
    End With

    With .Cells(RowMonth, ColEndNewMonth)
      With .Borders(xlEdgeRight)
        .LineStyle = BorderMonthRightLineStyle
        .Weight = BorderMonthRightWeight
        .Color = BorderMonthRightColor
      End With
    End With

    ' Copy value and formats for new month within RowDow from cells in middle of previous month
    ColSource = ColStartNewMonth - 14
    ColOffset = 0
    For ColCrnt = ColStartNewMonth To ColEndNewMonth
      .Cells(RowDow, ColCrnt).Value = .Cells(RowDow, ColSource + ColOffset).Value
      .Cells(RowDow, ColCrnt).HorizontalAlignment = .Cells(RowDow, ColSource + ColOffset).HorizontalAlignment
      .Cells(RowDow, ColCrnt).Font.Color = .Cells(RowDow, ColSource + ColOffset).Font.Color
      .Cells(RowDow, ColCrnt).Interior.Color = .Cells(RowDow, ColSource + ColOffset).Interior.Color
      If ColCrnt > ColStartNewMonth Then
        ' Only set left border if not firsst day of month so month border untouched
        .Cells(RowDow, ColCrnt).Borders(xlEdgeLeft).LineStyle = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeLeft).LineStyle
        .Cells(RowDow, ColCrnt).Borders(xlEdgeLeft).Weight = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeLeft).Weight
        .Cells(RowDow, ColCrnt).Borders(xlEdgeLeft).Color = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeLeft).Color
      End If
      .Cells(RowDow, ColCrnt).Borders(xlEdgeBottom).LineStyle = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeBottom).LineStyle
      .Cells(RowDow, ColCrnt).Borders(xlEdgeBottom).Weight = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeBottom).Weight
      .Cells(RowDow, ColCrnt).Borders(xlEdgeBottom).Color = .Cells(RowDow, ColSource + ColOffset).Borders(xlEdgeBottom).Color
      ColOffset = ColOffset + 1
      If ColOffset = 7 Then
        ColOffset = 0
      End If
    Next

    ' Set right border for month for row RowDow
    With .Cells(RowDow, ColEndNewMonth).Borders(xlEdgeRight)
      .LineStyle = BorderMonthRightLineStyle
      .Weight = BorderMonthRightWeight
      .Color = .Color
    End With

    ' Copy formats for new month within RowDom from cells in middle of previous month
    ' Set days of month
    ColSource = ColStartNewMonth - 14
    ColOffset = 0
    Dom = 1
    For ColCrnt = ColStartNewMonth To ColEndNewMonth
      .Cells(RowDom, ColCrnt).Value = Dom
      .Cells(RowDom, ColCrnt).HorizontalAlignment = .Cells(RowDom, ColSource + ColOffset).HorizontalAlignment
      .Cells(RowDom, ColCrnt).Font.Color = .Cells(RowDom, ColSource + ColOffset).Font.Color
      .Cells(RowDom, ColCrnt).Interior.Color = .Cells(RowDom, ColSource + ColOffset).Interior.Color
      If ColCrnt > ColStartNewMonth Then
        ' Only set left border if not firsst day of month so month border untouched
        .Cells(RowDom, ColCrnt).Borders(xlEdgeLeft).LineStyle = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeLeft).LineStyle
        .Cells(RowDom, ColCrnt).Borders(xlEdgeLeft).Weight = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeLeft).Weight
        .Cells(RowDom, ColCrnt).Borders(xlEdgeLeft).Color = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeLeft).Color
      End If
      .Cells(RowDom, ColCrnt).Borders(xlEdgeBottom).LineStyle = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeBottom).LineStyle
      .Cells(RowDom, ColCrnt).Borders(xlEdgeBottom).Weight = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeBottom).Weight
      .Cells(RowDom, ColCrnt).Borders(xlEdgeBottom).Color = .Cells(RowDom, ColSource + ColOffset).Borders(xlEdgeBottom).Color
      ColOffset = ColOffset + 1
      If ColOffset = 7 Then
        ColOffset = 0
      End If
      Dom = Dom + 1
    Next

    ' Set right border for month for row RowDom
    With .Cells(RowDom, ColEndNewMonth).Borders(xlEdgeRight)
      .LineStyle = BorderMonthRightLineStyle
      .Weight = BorderMonthRightWeight
      .Color = .Color
    End With

    ' Get pattern for last Sunday.  Assume same pattern used for Saturdays
    With .Cells(RowDataFirst, ColSunday)
      InteriorColor = .Interior.Color
      Pattern = .Interior.Pattern
      PatternColorIndex = .Interior.PatternColorIndex
      ' Get borders for last Sunday. Assume left border used for all borders
      With .Borders(xlEdgeLeft)
        BorderDayLeftLineStyle = .LineStyle
        BorderDayLeftWeight = .Weight
        BorderDayLeftColor = .Color
      End With
    End With

    ColCrnt = ColSunday + 6         ' Column for first Saturday of new month
    Do While True
      ' Set pattern for Saturday and Sunday for every data row
      For RowCrnt = RowDataFirst To RowLast
        .Cells(RowCrnt, ColCrnt).Interior.Pattern = Pattern
        .Cells(RowCrnt, ColCrnt).Interior.PatternColorIndex = PatternColorIndex
        .Cells(RowCrnt, ColCrnt).Interior.Color = InteriorColor
      Next
      ColCrnt = ColCrnt + 1     ' Advance to Sunday
      If ColCrnt > ColEndNewMonth Then
        ' All Saturdays and Sundays of new month marked
        Exit Do
      End If
      For RowCrnt = RowDataFirst To RowLast
        .Cells(RowCrnt, ColCrnt).Interior.Pattern = Pattern
        .Cells(RowCrnt, ColCrnt).Interior.PatternColorIndex = PatternColorIndex
        .Cells(RowCrnt, ColCrnt).Interior.Color = InteriorColor
      Next
      ColCrnt = ColCrnt + 6     ' Advance to next Saturday
      If ColCrnt > ColEndNewMonth Then
        ' All Saturdays and Sundays of new month marked
        Exit Do
      End If
    Loop

    ' Set borders of data cells for new month
    For RowCrnt = RowDataFirst To RowLast
      For ColCrnt = ColStartNewMonth To ColEndNewMonth
        If ColCrnt > ColStartNewMonth Then
          ' Only set border if not first day of month so left border for month untouched
          With .Cells(RowCrnt, ColCrnt)
            With .Borders(xlEdgeLeft)
              .LineStyle = BorderDayLeftLineStyle
              .Weight = BorderDayLeftWeight
              .Color = BorderDayLeftColor
            End With
          End With
        End If
        With .Cells(RowCrnt, ColCrnt)
          With .Borders(xlEdgeBottom)
            .LineStyle = BorderDayLeftLineStyle
            .Weight = BorderDayLeftWeight
            .Color = BorderDayLeftColor
          End With
        End With
      Next
      ' Set right border for month
      With .Cells(RowCrnt, ColEndNewMonth)
        With .Borders(xlEdgeRight)
          .LineStyle = BorderMonthRightLineStyle
          .Weight = BorderMonthRightWeight
          .Color = BorderMonthRightColor
        End With
      End With
    Next

  End With

End Sub
Function ColNumToCode(ByVal ColNum As Long) As String

  Dim ColCode As String
  Dim PartNum As Long

  ' Last updated 3 Feb 12.  Adapted to handle three character codes.

  If ColNum = 0 Then
    ColNumToCode = "0"
  Else
    ColCode = ""
    Do While ColNum > 0
      PartNum = (ColNum - 1) Mod 26
      ColCode = Chr(65 + PartNum) & ColCode
      ColNum = (ColNum - PartNum - 1) \ 26
    Loop
  End If

  ColNumToCode = ColCode

End Function