Public WKB As Workbook, ConSH As Worksheet, SH As Worksheet, NewSH As Worksheet
Public Filename As String, PICCH As ChartObject, FileNameSTR As String
Public InputWkb As Workbook, FolderName As String
Sub Create_Consolidated_Calendar()

Set InputWkb = ActiveWorkbook
CreateWorbook
DefineWorksheet
RemoveGridLines
Set SH = ThisWorkbook.Sheets("Sheet2")
Create_Calendar_PageHeader

Dim YearNumber As Integer
YearNumber = SH.Range("C9").Value

Dim M As Integer, MaxNumbOfDays As Integer
For M = 1 To 12
MName = MonthName(Month(DateSerial(YearNumber, M + 1, 0)), False)
DefineMonthCell (MName)
ActiveCell.Value = MonthName(Month(DateSerial(YearNumber, M + 1, 0)), False)
FormatHeaderCell
PrintDays
MonthNumber = M
MaxNumbOfDays = Day(DateSerial(YearNumber, M + 1, 0))
FirstDayWeek = Weekday(DateSerial(YearNumber, M, 1))
DayRow = ActiveCell.Offset(1, 0).Row
DayCol = ActiveCell.Column
ColNumb = DayCol
For DayNumber = 1 To MaxNumbOfDays
Cells(DayRow, DayCol + FirstDayWeek - 1).Activate
Cells(DayRow, DayCol + FirstDayWeek - 1).Value = DayNumber
FormatDateCell
DayCol = DayCol + 1
If DayCol + FirstDayWeek - 1 > ColNumb + 6 Then
DayCol = ColNumb
DayRow = DayRow + 1
FirstDayWeek = 1
End If
Next
With ActiveCell.CurrentRegion
.Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0).Columns(1).Font.ColorIndex = 9
End With
Next
ChangeTheColumnWidth

ExportPictureIntoWorksheet
'========================MonthWise======================
For M = 1 To 12
AddNewWorksheet
RemoveGridLines
MName = MonthName(Month(DateSerial(YearNumber, M + 1, 0)), False)
NewSH.Range("E15").Activate
ActiveCell.NumberFormat = "@"
ActiveCell.Value = MonthName(Month(DateSerial(YearNumber, M + 1, 0)), False) & " " & Year(DateSerial(YearNumber, M + 1, 0))
NewSH.Name = ActiveCell.Value & " Calendar"

MonthlyHeaders
PrintDays
MonthNumber = M
MaxNumbOfDays = Day(DateSerial(YearNumber, M + 1, 0))
FirstDayWeek = Weekday(DateSerial(YearNumber, M, 1))
DayRow = ActiveCell.Offset(1, 0).Row
DayCol = ActiveCell.Column
ColNumb = DayCol
For DayNumber = 1 To MaxNumbOfDays
Cells(DayRow, DayCol + FirstDayWeek - 1).Activate
Cells(DayRow, DayCol + FirstDayWeek - 1).Value = DayNumber
FormatDateCell
DayCol = DayCol + 1
If DayCol + FirstDayWeek - 1 > ColNumb + 6 Then
DayCol = ColNumb
DayRow = DayRow + 1
FirstDayWeek = 1
End If
Next

ExportPictureIntoMonthlyWorksheet (M)
Next

WKB.SaveAs Filename:=FolderName & "Calendar_Wkb.xlsx"
WKB.Close
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Speech.Speak ("Hi Created Monthly Calendars for the Year of " & SH.Range("C9").Value)
MsgBox "Hi Completed"
Application.SheetsInNewWorkbook = 3
End Sub

Function CreateWorbook()
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Set WKB = ActiveWorkbook
End Function
Function DefineWorksheet()
Set ConSH = WKB.Sheets("Sheet1")
End Function
Function RemoveGridLines()
ActiveWindow.DisplayGridlines = False
End Function

Function PrintDays()
rownum = ActiveCell.Row
columnNumb = ActiveCell.Column
Cells(rownum + 1, columnNumb).Value = "S"
Cells(rownum + 1, columnNumb + 1).Value = "M"
Cells(rownum + 1, columnNumb + 2).Value = "T"
Cells(rownum + 1, columnNumb + 3).Value = "W"
Cells(rownum + 1, columnNumb + 4).Value = "T"
Cells(rownum + 1, columnNumb + 5).Value = "F"
Cells(rownum + 1, columnNumb + 6).Value = "S"
Range(Cells(rownum + 1, columnNumb), Cells(rownum + 1, columnNumb + 6)).Select
FormatHeaderCell
End Function

Function DefineMonthCell(MName)
If MName = "January" Then
ConSH.Range("B5").Activate
ElseIf MName = "February" Then
ConSH.Range("J5").Activate
ElseIf MName = "March" Then
ConSH.Range("R5").Activate
ElseIf MName = "April" Then
ConSH.Range("B13").Activate
ElseIf MName = "May" Then
ConSH.Range("J13").Activate
ElseIf MName = "June" Then
ConSH.Range("R13").Activate
ElseIf MName = "July" Then
ConSH.Range("B21").Activate
ElseIf MName = "August" Then
ConSH.Range("J21").Activate
ElseIf MName = "September" Then
ConSH.Range("R21").Activate
ElseIf MName = "October" Then
ConSH.Range("B29").Activate
ElseIf MName = "November" Then
ConSH.Range("J29").Activate
ElseIf MName = "December" Then
ConSH.Range("R29").Activate
End If
Range(Cells(ActiveCell.Row, ActiveCell.Column), Cells(ActiveCell.Row, ActiveCell.Column + 6)).Merge
ActiveCell.Interior.ColorIndex = 9
End Function

Function ChangeTheColumnWidth()
ConSH.UsedRange.EntireColumn.ColumnWidth = 4
ConSH.Columns("A").ColumnWidth = 1
ConSH.Columns("I").ColumnWidth = 1
ConSH.Columns("Q").ColumnWidth = 1
ConSH.Columns("Y").ColumnWidth = 1
maxcol = ConSH.Range("Z1").End(xlToRight).Column
ConSH.Range(Cells(1, 26), Cells(1, maxcol)).Select
Selection.Columns.Hidden = True
ConSH.Rows("38:" & ConSH.Rows.Count).EntireRow.Hidden = True
ConSH.Rows("37").RowHeight = 5
ConSH.Range("B37:X37").Interior.ColorIndex = 9
End Function
Function Create_Calendar_PageHeader()
ConSH.Range("B2:X3").Merge
ConSH.Range("B2").Value = "Calendar For The Year Of " & SH.Range("C9")
ConSH.Range("B2").Activate
FormatHeaderCell
End Function
Function FormatDateCell()
With ActiveCell
.Font.Size = 15
.Font.Name = "Calibri"

.Font.ColorIndex = 1
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End Function
Function FormatHeaderCell()
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
If ActiveCell.Row = 2 Then
.Font.Size = 20
Else:
.Font.Size = 15
End If
.Font.Name = "Calibri"

If ActiveCell.Address <> "$C$2" And ActiveCell.Interior.ColorIndex <> 9 Then
.Interior.ColorIndex = 10
End If
If ActiveCell.Address = "$C$2" Then
.Interior.ColorIndex = 25
End If
.Font.ColorIndex = 2
.Font.Bold = True
End With
End Function

Function ExportPictureIntoWorksheet()
ConSH.Rows("5:21").Select
Selection.EntireRow.Insert

Filename = Application.GetOpenFilename

Dim PictureName As String

Dim Pic As Picture

ConSH.Rows("4").RowHeight = 3
ConSH.Rows("21").RowHeight = 3
Set Pic = ActiveSheet.Pictures.Insert(Filename)

Pic.Name = "Consolidated"
Pic.ShapeRange.LockAspectRatio = msoFalse

Pic.Height = 243
Pic.Width = 532
Pic.Left = 12
Pic.Top = 47

Dim CH As ChartObject

With ConSH.Range("B2:X54")
.BorderAround 1, xlThick, 9
.CopyPicture xlScreen, xlBitmap
Set CH = ConSH.ChartObjects.Add( _
Left:=.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
With CH
.Name = "Abcd"
.Activate
End With
End With
ActiveChart.Paste
postsplit = Split(Filename, "\")
FileNameSTR = postsplit(UBound(postsplit))
PostsplitFileNameSTR = Split(FileNameSTR, ".")
FileNameSTR = PostsplitFileNameSTR(0)
ActiveSheet.Name = "Consolidated Calendar"
FolderName = "Calendar_With_" & FileNameSTR & "_" & Format(Now, "YYYY_MM_DD_HH_MM_SS")

Application.Wait (Now + TimeValue("00:00:02"))
MkDir (InputWkb.Path & "\" & FolderName)
Application.Wait (Now + TimeValue("00:00:02"))
FolderName = InputWkb.Path & "\" & FolderName & "\"
CH.Chart.Export Filename:=FolderName & FileNameSTR & ConSH.Name & " " & ".jpg", filtername:="jpg"

ActiveSheet.ChartObjects("Abcd").Delete
End Function

Function AddNewWorksheet()
WKB.Sheets.Add after:=Worksheets(Sheets.Count)
Set NewSH = ActiveSheet
End Function

Function MonthlyHeaders()
Range("E15:K15").Select
With Selection
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
If ActiveCell.Row = 15 Then
.Font.Size = 20
Else:
.Font.Size = 15
End If
.Font.Name = "Calibri"

If ActiveCell.Row = 15 Then
.Interior.ColorIndex = 9
End If

.Font.ColorIndex = 2
.Font.Bold = True
End With
End Function

Function ExportPictureIntoMonthlyWorksheet(M)

With NewSH.Range("E3:K14")
Set PICCH = NewSH.ChartObjects.Add( _
Left:=.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
With PICCH
.Name = "pic"
.Activate
End With
End With
With NewSH.Shapes("pic").Fill
.Visible = msoTrue
.UserPicture Filename
.TextureTile = msoFalse
End With


NewSH.Range("E2:K2").Merge
NewSH.Range("E2").Value = SH.Range("C8").Value
NewSH.Range("E2").Select
FormatDateCell
With ActiveCell
.Font.Size = 21
.Interior.ColorIndex = 9
.Font.ColorIndex = 2
End With
NewSH.Columns("D").ColumnWidth = 0.2
NewSH.Columns("L").ColumnWidth = 0.2
LastRow = NewSH.Range("E" & Rows.Count).End(xlUp).Row
NewSH.Range(Cells(16, 5), Cells(LastRow, 5)).Font.ColorIndex = 9
NewSH.Range(Cells(2, 4), Cells(LastRow, 4)).Interior.ColorIndex = 9
NewSH.Range(Cells(2, 12), Cells(LastRow, 12)).Interior.ColorIndex = 9
With NewSH.Range(Cells(2, 5), Cells(LastRow, 11))
.BorderAround 1, xlThick, 9
.CopyPicture xlScreen, xlBitmap
Set CH = NewSH.ChartObjects.Add( _
Left:=.Left, _
Top:=.Top, _
Width:=.Width, _
Height:=.Height)
With CH
.Name = "Abcd"
.Activate
End With
End With
ActiveChart.Paste
CH.Chart.Export Filename:=FolderName & M & " " & FileNameSTR & " " & NewSH.Name & ".jpg", filtername:="jpg"
ActiveSheet.ChartObjects("Abcd").Delete

End Function