Create Calendar automatically

Annpan79

New Member
Joined
Sep 16, 2011
Messages
47
Hello, I'm hoping that someone can help if possible please.

I have created a tracker for tasks performed across our department. Each month has 5 rows (but this can increase depending on how many tasks come in) and the days are listed across in the columns.

Each year, we have to re-set the following;


Offset each month so that the first day falls correctly(1-31)
Reformat the colours (blue for weekends, white weekends, black for non days)

It is a bit of a pain having to re-set this every year, especially when you discover that you have set one day incorrectly which has thrown out the whole calendar and I was wondering if there was a way to do this through VBA,

I have put an example below.

SatSunMonTueWedThuFriSatSunMonTueWedThuFriSatSunMonTueWedThuFriSatSunMonTueWedThuFriSatSunMonTueWedThuFriSatSun
Jan 12345678910111213141516171819202122232425262728293031
Feb 12345678910111213141516171819202122232425262728
Mar 12345678910111213141516171819202122232425262728293031
Apr 123456789101112131415161718192021222324252627282930

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>
Thank you in advance
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
This is reasonably simple if you do it in stages.

Firstly you need to have a cell that holds the year (I have assumed A1)

Then for the months calculate the first of the month using =DATE(A$1,1,1) then =DATE(A$1,2,1) etc to =DATE(A$1,12,1)
Format the cell as Mmm so just the month name shows

The under the first day put the following formula: =IF(TEXT($A3,"DDD")=B$2,1,"")
Under the second day put this: =IF(B3="",IF(TEXT($A3,"DDD")=C$2,1,""),B3+1)
Copy the second formula across the rest of the days.

Then copy each line down and I should work
 
Upvote 0
Try this:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG20Sep55
[COLOR="Navy"]Dim[/COLOR] mDay [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] mMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Mth [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cColor [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Rw = 2
  
[COLOR="Navy"]For[/COLOR] Mth = 1 To 12
    [COLOR="Navy"]With[/COLOR] Cells(Rw, 1)
        .NumberFormat = "@"
        .Value = MonthName(Mth, True) & "  " & Year(Now)
        .Interior.Color = vbGreen '[COLOR="Green"][B]20[/B][/COLOR]
        .Font.Size = 12
    [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]If[/COLOR] Mth = 1 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] mDay = 1 To 36
            c = c + 1
            [COLOR="Navy"]With[/COLOR] Cells(Rw, mDay + 1)
              c = IIf(c = 8, 1, c)
              .Value = WeekdayName(c, True, 7)
              .Interior.ColorIndex = 20
              .Font.Size = 12
            [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] mDay
        Rw = Rw + 1
   [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Mth
        [COLOR="Navy"]Case[/COLOR] 2: mMax = IIf(Year(Now) Mod 4 = 0, 29, 28)
        [COLOR="Navy"]Case[/COLOR] 4, 6, 9, 11: mMax = 30
        [COLOR="Navy"]Case[/COLOR] Else: mMax = 31
    [COLOR="Navy"]End[/COLOR] Select
    col = Weekday(DateSerial(Year(Now), Mth, 1), 1) + 1
    col = IIf(col = 8, 1, col)
    
    [COLOR="Navy"]For[/COLOR] mDay = 1 To 31
        col = col + 1
        [COLOR="Navy"]With[/COLOR] Cells(Rw, col)
            .Value = mDay
            cColor = IIf(Cells(2, col) = "Sat" Or Cells(2, col) = "Sun", 20, 0)
            .Interior.ColorIndex = cColor
            .NumberFormat = "0"
            [COLOR="Navy"]If[/COLOR] mDay = mMax [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] For
        [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Next[/COLOR] mDay
Rw = Rw + 5
[COLOR="Navy"]Next[/COLOR] Mth
[COLOR="Navy"]With[/COLOR] Range("A2:AK43")
   .Font.Bold = True
   .Borders.Weight = 2
   .ColumnWidth = 5
   .Parent.Columns(1).ColumnWidth = 15
   .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Try this:-
Code:
[COLOR=Navy]Sub[/COLOR] MG20Sep55
[COLOR=Navy]Dim[/COLOR] mDay [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] col [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Rw [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] mMax [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] Mth [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] c [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] cColor [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
Rw = 2
  
[COLOR=Navy]For[/COLOR] Mth = 1 To 12
    [COLOR=Navy]With[/COLOR] Cells(Rw, 1)
        .NumberFormat = "@"
        .Value = MonthName(Mth, True) & "  " & Year(Now)
        .Interior.Color = vbGreen '[COLOR=Green][B]20[/B][/COLOR]
        .Font.Size = 12
    [COLOR=Navy]End[/COLOR] With
    [COLOR=Navy]If[/COLOR] Mth = 1 [COLOR=Navy]Then[/COLOR]
        [COLOR=Navy]For[/COLOR] mDay = 1 To 36
            c = c + 1
            [COLOR=Navy]With[/COLOR] Cells(Rw, mDay + 1)
              c = IIf(c = 8, 1, c)
              .Value = WeekdayName(c, True, 7)
              .Interior.ColorIndex = 20
              .Font.Size = 12
            [COLOR=Navy]End[/COLOR] With
       [COLOR=Navy]Next[/COLOR] mDay
        Rw = Rw + 1
   [COLOR=Navy]End[/COLOR] If
    [COLOR=Navy]Select[/COLOR] [COLOR=Navy]Case[/COLOR] Mth
        [COLOR=Navy]Case[/COLOR] 2: mMax = IIf(Year(Now) Mod 4 = 0, 29, 28)
        [COLOR=Navy]Case[/COLOR] 4, 6, 9, 11: mMax = 30
        [COLOR=Navy]Case[/COLOR] Else: mMax = 31
    [COLOR=Navy]End[/COLOR] Select
    col = Weekday(DateSerial(Year(Now), Mth, 1), 1) + 1
    col = IIf(col = 8, 1, col)
    
    [COLOR=Navy]For[/COLOR] mDay = 1 To 31
        col = col + 1
        [COLOR=Navy]With[/COLOR] Cells(Rw, col)
            .Value = mDay
            cColor = IIf(Cells(2, col) = "Sat" Or Cells(2, col) = "Sun", 20, 0)
            .Interior.ColorIndex = cColor
            .NumberFormat = "0"
            [COLOR=Navy]If[/COLOR] mDay = mMax [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Exit[/COLOR] For
        [COLOR=Navy]End[/COLOR] With
    [COLOR=Navy]Next[/COLOR] mDay
Rw = Rw + 5
[COLOR=Navy]Next[/COLOR] Mth
[COLOR=Navy]With[/COLOR] Range("A2:AK43")
   .Font.Bold = True
   .Borders.Weight = 2
   .ColumnWidth = 5
   .Parent.Columns(1).ColumnWidth = 15
   .HorizontalAlignment = xlCenter
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]
Regards Mick

Thanks Mick - That works Perfectly.

I have attempted to amend the code a bit so that it starts on Sunday, but when I have tried to change it to select the year from a cell reference (A1), however - it seems to be changing the date to 1899 (regardless of which date I choose - which is odd), i'm guessing it could be the mod?.

Also - Is it possible to generate the calendar at the next column along, eg the current years Calendar (2018) ends at column AK, so the next one starts at AM, and so on? - Just to give an audit trail. Obviously some housekeeping will take place periodically by us to ensure that we don't end up at column ZZZ.

Much appreciated
 
Upvote 0
Try this for "Sun" start for 4 years (alter number of years in code).
Calendar starts current year.
Code:
[COLOR="Navy"]Sub[/COLOR] MG21Sep37
[COLOR="Navy"]Dim[/COLOR] mDay [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] mMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Mth [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] cColor [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Y [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Yr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Y = 1
For Yr = 0 To 3 '[COLOR="Green"][B] Change number of years as required.[/B][/COLOR]
Rw = 2: c = 0
[COLOR="Navy"]For[/COLOR] Mth = 1 To 12
    [COLOR="Navy"]With[/COLOR] Cells(Rw, (Yr * 39) + 1)
        .NumberFormat = "@"
        .Value = MonthName(Mth, True) & "  " & Year(Now) + Yr
        .Interior.Color = vbGreen
        .Font.Size = 12
    [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]If[/COLOR] Mth = 1 [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]For[/COLOR] mDay = 1 To 37
            c = c + 1
            [COLOR="Navy"]With[/COLOR] Cells(Rw, mDay + (Yr * 39) + 1)
              c = IIf(c = 8, 1, c)
              .Value = WeekdayName(c, True, 1)
              .Interior.ColorIndex = 20
              .Font.Size = 12
            [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] mDay
        Rw = Rw + 1
   [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Select[/COLOR] [COLOR="Navy"]Case[/COLOR] Mth
        [COLOR="Navy"]Case[/COLOR] 2: mMax = IIf((Year(Now) + Yr) Mod 4 = 0, 29, 28)
        [COLOR="Navy"]Case[/COLOR] 4, 6, 9, 11: mMax = 30
        [COLOR="Navy"]Case[/COLOR] Else: mMax = 31
    [COLOR="Navy"]End[/COLOR] Select
    col = Weekday(DateSerial((Year(Now) + Yr), Mth, 1), 1)
  
    [COLOR="Navy"]For[/COLOR] mDay = 1 To 31
        col = col + 1
        [COLOR="Navy"]With[/COLOR] Cells(Rw, col + (Yr * 39))
            .Value = mDay
            cColor = IIf(Cells(2, col + Y - 1) = "Sat" Or Cells(2, col + Y - 1) = "Sun", 20, 0)
            .Interior.ColorIndex = cColor
            .NumberFormat = "0"
            [COLOR="Navy"]If[/COLOR] mDay = mMax [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] For
        [COLOR="Navy"]End[/COLOR] With
    [COLOR="Navy"]Next[/COLOR] mDay
Rw = Rw + 5
[COLOR="Navy"]Next[/COLOR] Mth
[COLOR="Navy"]With[/COLOR] Range("A2:AL58").Offset(, Y - 1)
   .Font.Bold = True
   .Borders.Weight = 2
   .ColumnWidth = 5
   .Parent.Columns(1 + Y - 1).ColumnWidth = 15
   .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
Y = Y + 39
[COLOR="Navy"]Next[/COLOR] Yr
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi Mick, Sorry for the late reply.

That is absolutely brilliant thank you so much. it works perfectly :):):):)
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,034
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top