Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Modify Yearly Calendar to Monthly Calendar Excel 2000?
Hello,
Below you will find a yearly calendar vba code that creates a worksheet for each month at one time. I would like to change the calendar to monthly using a input box choosing the month and year. How can I modify the code to use a input box to select the month and year so that is will create one worksheet for a selected month and year? Option Explicit Sub BuildCalendar_North() 'Need activeworkbook sheet named Event List: '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 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 End If sh.Name = [A1] & " " & [G1] 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, 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, James |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
monthly tabs missing in yearly calendar | Excel Discussion (Misc queries) | |||
yearly calendar | Excel Discussion (Misc queries) | |||
Adding a yearly calendar to excel spreadsheet | Excel Worksheet Functions | |||
automate calendar dates on worksheets to make a yearly planner | Excel Discussion (Misc queries) | |||
Monthly calendar in EXCEL? | Excel Discussion (Misc queries) |