Hello,
I have a calendar that puts each month on a separate worksheet within
the same workbook. How can the vba code be changed so that I can select
one month and it will be on one worksheet. Then when I select another
month it will be on the same worksheet but it clears the other month
off? Also, I need to be able to change the year.
VBA Calendar Code:
Option Explicit
Sub DeleteSheets_North()
Dim Sht As Worksheet
For Each Sht In ThisWorkbook.Worksheets
Application.DisplayAlerts = False
'Reads characters left to right(begin at end count
backwards)
If Right(Sht.Name, 5) = "NORTH" Then
Sht.Delete
Application.DisplayAlerts = True
End If
Next Sht
'Run Macro Below
BuildCalendar_North
End Sub
Sub BuildCalendar_North()
'Need activeworkbook sheet named Settings_North:
'first event name in A2
'the date in B2 and so forth down the column
'with no breaks or interruptions
Dim yr As Long
Dim sName As String
Dim StartDate As Date
Dim EndDate As Date
Dim Sh As Worksheet
Dim Rng As Range, cell As Range
Dim dt As Date, s As String
Dim idex As Long, i As Long
Dim v(1 To 366) As String
Dim nt As Variant
Dim mmyy As String
Application.ScreenUpdating = False
With Worksheets("Settings_North")
dt = .Cells(2, 2).Value
yr = Year(dt)
nt = .Cells(2, 6).Value
StartDate = DateSerial(yr, 1, 1)
EndDate = DateSerial(yr, 12, 31)
Set Rng = .Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))
End With
For Each cell In Rng
idex = cell.Offset(0, 1).Value - StartDate + 1
v(idex) = v(idex) & Chr(10) & cell.Value
Next
For i = 1 To 12
On Error Resume Next
Application.DisplayAlerts = False
sName = Format(DateSerial(yr, i, 1), "mmmm")
Worksheets(sName).Delete
Application.DisplayAlerts = False
On Error GoTo 0
Next i
'Worksheets.Add after:=Worksheets(Worksheets.Count)
'Set sh = ActiveSheet
For i = StartDate To EndDate
If Day(i) = 1 Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
Set Sh = ActiveSheet
Sh.Name = Format(i, "mmmm")
MakeCalendar_North Sh, yr, v
'Run Macro
BackButton
'Sheet Name
Sh.Name = [A1] & " " & [G1]
End If
Next
Application.ScreenUpdating = True 'False
End Sub
Sub MakeCalendar_North(Sh As Worksheet, yr As Long, v() As String)
Dim dt As Date, dt1 As Date
Dim i As Long, j As Long, k As Long
Dim l As Long, m As Long, n As Long
Dim cell As Range, rw As Long, col As Long
Application.ScreenUpdating = False
Sh.Range("A:G").EntireColumn.ColumnWidth = 22
Sh.Rows(1).RowHeight = 30
With Sh.Cells(1, 1).Resize(1, 7)
.HorizontalAlignment = xlLeft 'xlCenterAcrossSelection
.VerticalAlignment = xlCenter
End With
Sh.Cells(1, 1).Value = "'" & Sh.Name & " " & yr
Sh.Cells(1, 1).Font.Bold = True
Sh.Cells(1, 1).Font.Size = 20
Sh.Cells(1, 4).Value = Sheets("Settings_North").Range("F3").Value
Sh.Cells(1, 4).Font.Bold = True
Sh.Cells(1, 4).Font.Size = 18
Sh.Cells(1, 7).Value = "NORTH"
Sh.Cells(1, 7).Font.Bold = True
Sh.Cells(1, 7).Font.Size = 18
With Sh.Cells(2, 1).Resize(1, 7)
.Value = Array("Sunday", "Monday", _
"Tuesday", "Wednesday", "Thursday", _
"Friday", "Saturday")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Bold = True
.Font.Size = 16
.EntireRow.RowHeight = 20
End With
For Each cell In Sh.Cells(2, 1).Resize(7, 7)
cell.BorderAround Weight:=xlMedium
cell.WrapText = True
If cell.Row >= 3 Then
cell.HorizontalAlignment = xlLeft
cell.VerticalAlignment = xlTop
End If
Next
dt = DateValue(Sh.Name & " 1," & yr)
i = Weekday(dt, vbSunday)
dt1 = DateSerial(Year(dt), Month(dt) + 1, 0)
n = dt - DateSerial(Year(dt), 1, 1)
col = i
rw = 3
For k = Day(dt) To Day(dt1)
n = n + 1
Cells(rw, col).Value = Trim(k & v(n))
Cells(rw, col).BorderAround Weight:=xlMedium
col = col + 1
If col > 7 Then
col = 1
rw = rw + 1
End If
Next
Sh.Cells(3, 1).Resize(6, 1).EntireRow.RowHeight = 95
Range("A3:G8").Select
With Selection.Font
.Name = "Arial"
.Size = 12
End With
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = -3
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape 'xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = True 'False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
ActiveWindow.DisplayGridlines = False
Range("A3").Select
Application.ScreenUpdating = True 'False
End Sub
Thank you for your help in advance,
jfcby
Similar Threads
