Creating Multiple Calendar

A

Av8tordude

Well-known Member
Joined
Oct 13, 2007
Messages
1,074
Office Version
  1. 2019
Platform
  1. Windows
This code create a calendar. I would like to create calendars for the whole year. The calendar setup example is listed below. How can I achieve this? Thanks

Code: 
Sub CreateCalendar()
Dim csheet As Worksheet
Set csheet = ThisWorkbook.Sheets("Sheet1")


selDate = [b2]
fMon = DateSerial(Year(selDate), Month(selDate), 1)
lMon = CDate(Application.WorksheetFunction.EoMonth(fMon, 0))


stRow = 4


'clear last cal
Rows(4).ClearContents
Rows(6).ClearContents
Rows(8).ClearContents
Rows(10).ClearContents
Rows(12).ClearContents
Rows(14).ClearContents




'determine what weekday 1st is. . .
If Weekday(fMon) = 1 Then
    stCol = 2
ElseIf Weekday(fMon) = 2 Then
    stCol = 3
ElseIf Weekday(fMon) = 3 Then
    stCol = 4
ElseIf Weekday(fMon) = 4 Then
    stCol = 5
ElseIf Weekday(fMon) = 5 Then
    stCol = 6
ElseIf Weekday(fMon) = 6 Then
    stCol = 7
ElseIf Weekday(fMon) = 7 Then
    stCol = 8
End If


Application.EnableEvents = False
For x = 1 To Day(lMon)
    If FirstT = Empty Then
        csheet.Cells(stRow, stCol) = fMon
        FirstT = 1
    Else
        fMon = fMon + 1
        csheet.Cells(stRow, stCol) = fMon
    End If
    
    If stCol = 8 Then
        stCol = 2
        stRow = stRow + 2
    Else
        stCol = stCol + 1
    End If
Next x
Application.EnableEvents = True
End Sub

January
SundayMondayTuesdayWednesdayThursdayFridaySaturday
12345
6789101112
13141516171819
20212223242526
2728293031
February
SundayMondayTuesdayWednesdayThursdayFridaySaturday
12
3456789
10111213141516
17181920212223
2425262728
March
SundayMondayTuesdayWednesdayThursdayFridaySaturday
12
3456789
10111213141516
17181920212223
24252627282930
31

<tbody>
</tbody>
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
Try:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG03Oct25
'[COLOR="Green"][B] Month Calendars only[/B][/COLOR]
[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]
[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] Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Dt [COLOR="Navy"]As[/COLOR] Date, cPlus [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

[COLOR="Navy"]With[/COLOR] Columns("A:G")
    .ClearContents
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
   Rw = 2
   col = 8
[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
        Rw = Rw + 1
    [COLOR="Navy"]End[/COLOR] With
        [COLOR="Navy"]For[/COLOR] mDay = 1 To 7
            [COLOR="Navy"]With[/COLOR] Cells(Rw, mDay)
                .Value = WeekdayName(mDay, True, 1)
                .Interior.ColorIndex = 20
                .Font.Size = 12
            [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] mDay
Rw = Rw + 1

[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

[COLOR="Navy"]For[/COLOR] mDay = 1 To 31
    col = Weekday(DateSerial(Year(Now), Mth, mDay))
    [COLOR="Navy"]With[/COLOR] Cells(Rw, col)
        .Value = mDay
        .NumberFormat = "0"
    [COLOR="Navy"]End[/COLOR] With
            [COLOR="Navy"]If[/COLOR] col Mod 7 = 0 [COLOR="Navy"]Then[/COLOR]
            Rw = Rw + IIf(col Mod 7 = 0, 1, 0)
            [COLOR="Navy"]End[/COLOR] If
            cPlus = cPlus + IIf(col Mod 7 = 0, 8, 0)
                [COLOR="Navy"]If[/COLOR] mDay = mMax [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] For
[COLOR="Navy"]Next[/COLOR] mDay

Rw = Rw + 2
[COLOR="Navy"]Next[/COLOR] Mth

Range("A2").Resize(Rw, 7).Borders.Weight = 2
Columns("B:G").ColumnWidth = 6
Columns("A:A").ColumnWidth = 12
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Hi MickG,

The code works, however the code should skip 1 row after each Dated row because I will be adding data in each date. Also, In months November and December, it creates extra empty rows. All other months looks good except I need to make sure there are empty rows to allow for data to be entered in each date.
 
Upvote 0
I've manage to insert an extra row in each month to allow for entering data in each date, however the month of August, November and December have an extra two rows added with should not be added. Here's the update code that I changed (highlighted in red)

Code: 
Sub MG03Oct25()
' Month Calendars only
Dim mDay As Long, col As Long, Rw As Long, mMax As Long, Mth As Long
Dim Rng As Range, Dn As Range, n As Long, Dic As Object
Dim Sp As Variant, Dt As Date, cPlus As Long


With Columns("A:G")
    .ClearContents
    .HorizontalAlignment = xlCenter
End With
   Rw = 2
   col = 8
For Mth = 1 To 12
    
    With Cells(Rw, 1)
        .NumberFormat = "@"
        .Value = MonthName(Mth, True) & "  " & Year(Now)
        .Interior.Color = vbGreen '20
        .Font.Size = 12
        Rw = Rw + 1
    End With
        For mDay = 1 To 7
            With Cells(Rw, mDay)
                .Value = WeekdayName(mDay, True, 1)
                .Interior.ColorIndex = 20
                .Font.Size = 12
            End With
       Next mDay
Rw = Rw + 1


Select Case Mth
    Case 2: mMax = IIf(Year(Now) Mod 4 = 0, 29, 28)
    Case 4, 6, 9, 11: mMax = 30
    Case Else: mMax = 31
End Select


For mDay = 1 To 31
    col = Weekday(DateSerial(Year(Now), Mth, mDay))
    With Cells(Rw, col)
        .Value = mDay
        .NumberFormat = "0"
    End With
            If col Mod 7 = 0 Then
            Rw = Rw + IIf(col Mod 7 = 0, [COLOR=#ff0000]2[/COLOR], 0)
            End If
            cPlus = cPlus + IIf(col Mod 7 = 0, 8, 0)
                If mDay = mMax Then Exit For
Next mDay


Rw = Rw + 2
Next Mth


Range("A2").Resize(Rw, 7).Borders.Weight = 2
Columns("B:G").ColumnWidth = 6
Columns("A:A").ColumnWidth = 12
End Sub
 
Upvote 0
This is a bit of a work round but might do !!!
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Oct14
'[COLOR="Green"][B] Month Calendars only[/B][/COLOR]
[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]
[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] Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Dt [COLOR="Navy"]As[/COLOR] Date, cPlus [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]


[COLOR="Navy"]With[/COLOR] Columns("A:G")
    .ClearContents
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
   Rw = 2
   col = 8
[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
        Rw = Rw + 1
    [COLOR="Navy"]End[/COLOR] With
        [COLOR="Navy"]For[/COLOR] mDay = 1 To 7
            [COLOR="Navy"]With[/COLOR] Cells(Rw, mDay)
                .Value = WeekdayName(mDay, True, 1)
                .Interior.ColorIndex = 20
                .Font.Size = 12
            [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] mDay
Rw = Rw + 1


[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


[COLOR="Navy"]For[/COLOR] mDay = 1 To 31
    col = Weekday(DateSerial(Year(Now), Mth, mDay))
    [COLOR="Navy"]With[/COLOR] Cells(Rw, col)
        .Value = mDay
        .NumberFormat = "0"
    [COLOR="Navy"]End[/COLOR] With
            [COLOR="Navy"]If[/COLOR] col Mod 7 = 0 [COLOR="Navy"]Then[/COLOR]
            Rw = Rw + IIf(col Mod 7 = 0, 2, 0)
            [COLOR="Navy"]End[/COLOR] If
            cPlus = cPlus + IIf(col Mod 7 = 0, 8, 0)
                [COLOR="Navy"]If[/COLOR] mDay = mMax [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] For
[COLOR="Navy"]Next[/COLOR] mDay


Rw = Rw + 2
[COLOR="Navy"]Next[/COLOR] Mth
[COLOR="Navy"]Set[/COLOR] Rng = Range("A:A").SpecialCells(xlCellTypeBlanks)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    [COLOR="Navy"]If[/COLOR] Dn.Count > 1 [COLOR="Navy"]Then[/COLOR]
        Dn(1).Resize(Dn.Count - 1).EntireRow.Delete
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn

[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Rng.Resize(Rng.Count + 1, 7).Borders.Weight = 2
Columns("B:G").ColumnWidth = 6
Columns("A:A").ColumnWidth = 12

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
This should be better !!!
Code: 
[COLOR="Navy"]Sub[/COLOR] MG05Oct05
[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]
[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] Dic [COLOR="Navy"]As[/COLOR] Object, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, Dt [COLOR="Navy"]As[/COLOR] Date, cPlus [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]


[COLOR="Navy"]With[/COLOR] Columns("A:G")
    .ClearContents
    .HorizontalAlignment = xlCenter
[COLOR="Navy"]End[/COLOR] With
   Rw = 2
   col = 8
[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
        Rw = Rw + 1
    [COLOR="Navy"]End[/COLOR] With
        [COLOR="Navy"]For[/COLOR] mDay = 1 To 7
            [COLOR="Navy"]With[/COLOR] Cells(Rw, mDay)
                .Value = WeekdayName(mDay, True, 1)
                .Interior.ColorIndex = 20
                .Font.Size = 12
            [COLOR="Navy"]End[/COLOR] With
       [COLOR="Navy"]Next[/COLOR] mDay
Rw = Rw + 1


[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


For mDay = 1 To mMax '[COLOR="Green"][B]31[/B][/COLOR]
    col = Weekday(DateSerial(Year(Now), Mth, mDay))
    [COLOR="Navy"]With[/COLOR] Cells(Rw, col)
        .Value = mDay
        .NumberFormat = "0"
    [COLOR="Navy"]End[/COLOR] With
            [COLOR="Navy"]If[/COLOR] col Mod 7 = 0 And mDay < mMax [COLOR="Navy"]Then[/COLOR]
            Rw = Rw + IIf(col Mod 7 = 0, 2, 0)
            [COLOR="Navy"]End[/COLOR] If
            cPlus = cPlus + IIf(col Mod 7 = 0, 8, 0)
                [COLOR="Navy"]If[/COLOR] mDay = mMax [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] For
[COLOR="Navy"]Next[/COLOR] mDay


Rw = Rw + 2
[COLOR="Navy"]Next[/COLOR] Mth

[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
Rng.Resize(Rng.Count + 1, 7).Borders.Weight = 2
Columns("B:G").ColumnWidth = 6
Columns("A:A").ColumnWidth = 12

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Wonderful MickG. Works great! Thank you very much for your help and continue help to solving this. Really appreciate it!!!
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Formula for weekdays of date in another cell
Replies
4
Views
439
Jaxi
J
T
  • Question
count overtime hours in a calendar
Replies
4
Views
102
ttowncorp
T
S
  • Question
count number of unique Mondays in a date column
Replies
4
Views
652
Dave Patton
D
F
  • Solved
Issue with VBA code I created for work
Replies
7
Views
629
KAPOK
K
L
  • Solved
Would like to make edits to VBA Calendar Code
Replies
8
Views
375
Legacy 352679
L

Forum statistics

Threads
1,214,584
Messages
6,120,385
Members
448,956
Latest member
JPav

Share this page

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