Create 12 tabs in the workbook, and repeat the process for each month.

Change Case 1’s range to “g3”, then resume the rest going down the list starting over at a3, and finishing Case 7 with f3.

Complete code should look like this:
Sub Create_Calendar()
‘
‘MACROS BY EXCELZOOM.COM
‘
ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _
Scenarios:=False

Application.ScreenUpdating = False

On Error GoTo ErrorMessage

Range(“a1:g14”).Clear

InputDate = InputBox(“Type in Month and Year for Calendar “)

If InputDate = “” Then Exit Sub

FirstDay = DateValue(InputDate)

If Day(FirstDay) <> 1 Then
FirstDay = DateValue(Month(FirstDay) & “/1/” & _
Year(FirstDay))
End If

Range(“a1”).NumberFormat = “mmmm yyyy”

With Range(“a1:g1”)
.HorizontalAlignment = xlCenterAcrossSelection
.VerticalAlignment = xlCenter
.Font.Size = 18
.Font.Bold = True
.RowHeight = 35
End With

With Range(“a2:g2”)
.ColumnWidth = 14
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = xlHorizontal
.Font.Size = 12
.Font.Bold = True
.RowHeight = 20
End With

Range(“a2”) = “Monday”
Range(“b2”) = “Tuesday”
Range(“c2”) = “Wednesday”
Range(“d2”) = “Thursday”
Range(“e2”) = “Friday”
Range(“f2”) = “Saturday”
Range(“g2”) = “Sunday”

With Range(“a3:g8”)
.HorizontalAlignment = xlRight
.VerticalAlignment = xlTop
.Font.Size = 18
.Font.Bold = True
.RowHeight = 21
End With

Range(“a1”).Value = Application.Text(InputDate, “mmmm yyyy”)

DayofWeek = Weekday(FirstDay)

CurrentYear = Year(FirstDay)
CurrentMonth = Month(FirstDay)

LastDay = DateSerial(CurrentYear, CurrentMonth + 1, 1)

Select Case DayofWeek
Case 1
Range(“g3”).Value = 1
Case 2
Range(“a3”).Value = 1
Case 3
Range(“b3”).Value = 1
Case 4
Range(“c3”).Value = 1
Case 5
Range(“d3”).Value = 1
Case 6
Range(“e3”).Value = 1
Case 7
Range(“f3”).Value = 1
End Select

For Each cell In Range(“a3:g8”)
RowCell = cell.Row
ColCell = cell.Column

If cell.Column = 1 And cell.Row = 3 Then

ElseIf cell.Column <> 1 Then
If cell.Offset(0, -1).Value >= 1 Then
cell.Value = cell.Offset(0, -1).Value + 1

If cell.Value > (LastDay – FirstDay) Then
cell.Value = “”

Exit For
End If
End If

ElseIf cell.Row > 3 And cell.Column = 1 Then
cell.Value = cell.Offset(-1, 6).Value + 1

If cell.Value > (LastDay – FirstDay) Then
cell.Value = “”

Exit For
End If
End If
Next

For x = 0 To 5
Range(“A4”).Offset(x * 2, 0).EntireRow.Insert
With Range(“A4:G4”).Offset(x * 2, 0)
.RowHeight = 65
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Font.Size = 10
.Font.Bold = False

.Locked = False
End With

With Range(“A3”).Offset(x * 2, 0).Resize(2, _
7).Borders(xlLeft)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With

With Range(“A3”).Offset(x * 2, 0).Resize(2, _
7).Borders(xlRight)
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
Range(“A3”).Offset(x * 2, 0).Resize(2, 7).BorderAround _
Weight:=xlThick, ColorIndex:=xlAutomatic
Next
If Range(“A13”).Value = “” Then Range(“A13”).Offset(0, 0) _
.Resize(2, 8).EntireRow.Delete

ActiveWindow.DisplayGridlines = False

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _
Scenarios:=True

ActiveWindow.WindowState = xlMaximized
ActiveWindow.ScrollRow = 1

Application.ScreenUpdating = True

Exit Sub

ErrorMessage:
MsgBox “You may not have entered your Month and Year correctly.” _
& Chr(13) & “Spell the Month correctly” _
& ” (or use 3 letter abbreviation)” _
& Chr(13) & “and 4 digits for the Year”
InputDate = InputBox(“Type in Month and Year for Calendar”)
If InputDate = “” Then Exit Sub
Resume
End Sub

Its about this section of the code:

Now that we have the dates, we’ll want to create a little space to enter in some data. To do this we’ll create a new row under each row that contains the dates.
For x = 0 To 5
Range(“A4″).Offset(x * 2, 0).EntireRow.Insert
With Range(“A4:G4″).Offset(x * 2, 0)
.RowHeight = 65
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = True
.Font.Size = 10
.Font.Bold = False
.Locked = False
End With

my question is, how can I extend typing area into 2 separate rows?

Christopher