Creating Multiple Calendar

A

Av8tordude

Well-known Member
Joined
Oct 13, 2007
Messages
1,075
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

[TABLE="width: 910"]
<tbody>[TR]
[TD="colspan: 7"]January[/TD]
[/TR]
[TR]
[TD]Sunday[/TD]
[TD]Monday[/TD]
[TD]Tuesday[/TD]
[TD]Wednesday[/TD]
[TD]Thursday[/TD]
[TD]Friday[/TD]
[TD]Saturday[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]5[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]6[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]9[/TD]
[TD="align: right"]10[/TD]
[TD="align: right"]11[/TD]
[TD="align: right"]12[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]13[/TD]
[TD="align: right"]14[/TD]
[TD="align: right"]15[/TD]
[TD="align: right"]16[/TD]
[TD="align: right"]17[/TD]
[TD="align: right"]18[/TD]
[TD="align: right"]19[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]20[/TD]
[TD="align: right"]21[/TD]
[TD="align: right"]22[/TD]
[TD="align: right"]23[/TD]
[TD="align: right"]24[/TD]
[TD="align: right"]25[/TD]
[TD="align: right"]26[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]27[/TD]
[TD="align: right"]28[/TD]
[TD="align: right"]29[/TD]
[TD="align: right"]30[/TD]
[TD="align: right"]31[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 7"]February[/TD]
[/TR]
[TR]
[TD]Sunday[/TD]
[TD]Monday[/TD]
[TD]Tuesday[/TD]
[TD]Wednesday[/TD]
[TD]Thursday[/TD]
[TD]Friday[/TD]
[TD]Saturday[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]9[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[TD="align: right"]11[/TD]
[TD="align: right"]12[/TD]
[TD="align: right"]13[/TD]
[TD="align: right"]14[/TD]
[TD="align: right"]15[/TD]
[TD="align: right"]16[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]17[/TD]
[TD="align: right"]18[/TD]
[TD="align: right"]19[/TD]
[TD="align: right"]20[/TD]
[TD="align: right"]21[/TD]
[TD="align: right"]22[/TD]
[TD="align: right"]23[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]24[/TD]
[TD="align: right"]25[/TD]
[TD="align: right"]26[/TD]
[TD="align: right"]27[/TD]
[TD="align: right"]28[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="colspan: 7"]March[/TD]
[/TR]
[TR]
[TD]Sunday[/TD]
[TD]Monday[/TD]
[TD]Tuesday[/TD]
[TD]Wednesday[/TD]
[TD]Thursday[/TD]
[TD]Friday[/TD]
[TD]Saturday[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]2[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]3[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]5[/TD]
[TD="align: right"]6[/TD]
[TD="align: right"]7[/TD]
[TD="align: right"]8[/TD]
[TD="align: right"]9[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]10[/TD]
[TD="align: right"]11[/TD]
[TD="align: right"]12[/TD]
[TD="align: right"]13[/TD]
[TD="align: right"]14[/TD]
[TD="align: right"]15[/TD]
[TD="align: right"]16[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]17[/TD]
[TD="align: right"]18[/TD]
[TD="align: right"]19[/TD]
[TD="align: right"]20[/TD]
[TD="align: right"]21[/TD]
[TD="align: right"]22[/TD]
[TD="align: right"]23[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]24[/TD]
[TD="align: right"]25[/TD]
[TD="align: right"]26[/TD]
[TD="align: right"]27[/TD]
[TD="align: right"]28[/TD]
[TD="align: right"]29[/TD]
[TD="align: right"]30[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD="align: right"]31[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
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

W
  • Solved
Formula Error: Error applying formula with VBA even though it works manually
Replies
3
Views
100
6StringJazzer
6StringJazzer
D
  • Solved
Is there a quick way to create / fill this list
2 3
Replies
20
Views
380
Eric W
Eric W
B
  • Solved
VBA to check if worksheet exists
Replies
8
Views
315
bdt
B
K
  • Question Question
Annual Event Calculation
Replies
5
Views
364
StephenCrump
S
J
  • Question Question
Formula for weekdays of date in another cell
Replies
4
Views
1K
Jaxi
J

Forum statistics

Threads
1,223,952
Messages
6,175,594
Members
452,656
Latest member
earth

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