Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Calendar DropDown & Scrollbar HELP, Excel 2000-2003
Hey,
I'm tring to modify a calendar, some progress has been made. With the code below I've added a Dropdown down box for the months and a scrollbar for the year from the worksheet toolbar. But, I can't get the them to work. All my efforts so far have been in vain. Right now when I try to make the calendar it takes me to the error message at the end of the code Not working correctly! My knowledge in vba is limited and I'm trying to learn more all help will be greatly appreciated! CODE: Sub CalendarMaker() Dim Da As Variant Dim Da2 As Range Dim MyDate 'Backup file located in Module3 this workbook ' Unprotect sheet if had previous calendar to prevent error. ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _ Scenarios:=False ' Prevent screen flashing while drawing calendar. Application.ScreenUpdating = False ' Set up error trapping. On Error GoTo MyErrorTrap ' Clear area a1:g14 including any previous calendar. Range("a1:g14").Clear ' Use InputBox to get desired month and year and set variable '?NOT IN USE? ' MyInput. Da = DropDown2_Change 'InputBox("Type in Month and year for Calendar ") Da2 = Sheet2.Range("i2") ' Allow user to end macro with Cancel in InputBox. If Da = "" Then Exit Sub If Da2 = "" Then Exit Sub ' Get the date value of the beginning of inputted month. StartDay = "=Date(MyDate)" ' Check if valid date but not the first of the month ' -- if so, reset StartDay to first day of month. If Day(StartDay) < 1 Then StartDay = DateValue(Month(StartDay) & "/1/" & _ Year(StartDay)) End If ' Prepare cell for Month and Year as fully spelled out. Sheet1.Range("a1").Value = Da '.NumberFormat = "mmmm" Sheet1.Range("b1").Value = Da2 '.NumberFormat = "yyyy" ' Center the Month and Year label across a1:g1 with appropriate ' size, height and bolding. With Range("a1:b1") .HorizontalAlignment = xlCenterAcrossSelection .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .RowHeight = 35 End With ' Prepare a2:g2 for day of week labels with centering, size, ' height and bolding. With Range("a2:g2") .ColumnWidth = 14 .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = xlHorizontal .Font.Size = 12 .Font.Bold = True .RowHeight = 20 End With ' Put days of week in a2:g2. Range("a2") = "Sunday" Range("b2") = "Monday" Range("c2") = "Tuesday" Range("d2") = "Wednesday" Range("e2") = "Thursday" Range("f2") = "Friday" Range("g2") = "Saturday" ' Prepare a3:g7 for dates with left/top alignment, size, height ' and bolding. With Range("a3:g8") .HorizontalAlignment = xlRight .VerticalAlignment = xlTop .Font.Size = 18 .Font.Bold = True .RowHeight = 21 End With ' Put inputted month fully spelling out into "a1". Sheet1.Range("a1").Value = Da 'Application.Text(MyInput, "mmmm") ' Put inputted year fully spelling out into "b1". Sheet1.Range("b1").Value = Da2 '= Application.Text(MyInput, "yyyy") ' Set variable and get which day of the week the month starts. DayofWeek = Weekday(StartDay) ' Set variables to identify the year and month as separate ' variables. CurYear = Year(StartDay) CurMonth = Month(StartDay) ' Set variable and calculate the first day of the next month. FinalDay = DateSerial(CurYear, CurMonth + 1, 1) ' Place a "1" in cell position of the first day of the chosen ' month based on DayofWeek. Select Case DayofWeek Case 1 Range("a3").Value = 1 Case 2 Range("b3").Value = 1 Case 3 Range("c3").Value = 1 Case 4 Range("d3").Value = 1 Case 5 Range("e3").Value = 1 Case 6 Range("f3").Value = 1 Case 7 Range("g3").Value = 1 End Select ' Loop through range a3:g8 incrementing each cell after the "1" ' cell. For Each cell In Range("a3:g8") RowCell = cell.Row ColCell = cell.Column ' Do if "1" is in first column. If cell.Column = 1 And cell.Row = 3 Then ' Do if current cell is not in 1st column. ElseIf cell.Column < 1 Then If cell.Offset(0, -1).Value = 1 Then cell.Value = cell.Offset(0, -1).Value + 1 ' Stop when the last day of the month has been ' entered. If cell.Value (FinalDay - StartDay) Then cell.Value = "" ' Exit loop when calendar has correct number of ' days shown. Exit For End If End If ' Do only if current cell is not in Row 3 and is in Column 1. ElseIf cell.Row 3 And cell.Column = 1 Then cell.Value = cell.Offset(-1, 6).Value + 1 ' Stop when the last day of the month has been entered. If cell.Value (FinalDay - StartDay) Then cell.Value = "" ' Exit loop when calendar has correct number of days ' shown. Exit For End If End If Next ' Create Entry cells, format them centered, wrap text, and border ' around days. 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 ' Unlock these cells to be able to enter text later after ' sheet is protected. .Locked = False End With ' Put border around the block of dates. 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 ' Turn off gridlines. ActiveWindow.DisplayGridlines = False ' Protect sheet to prevent overwriting the dates. ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=False 'True ' Resize window to show all of calendar (may have to be adjusted ' for video configuration). ActiveWindow.WindowState = xlMaximized ActiveWindow.ScrollRow = 1 'Macro Sets Current Day Call DayToGoTo ' Allow screen to redraw with calendar showing. Application.ScreenUpdating = True ' Prevent going to error trap unless error found by exiting Sub ' here. Exit Sub MyErrorTrap: MsgBox "Not Working Correctly!" If Da = "" Then Exit Sub If Da2 = "" Then Exit Sub Resume End Sub Thank you for your help in advance, jfcby |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Calendar DropDown & Scrollbar HELP, Excel 2000-2003
Why not use one of the available Calendar controls ?
Either on your system or search the web. Then it's already made for you. NickHK "jfcby" wrote in message oups.com... Hey, I'm tring to modify a calendar, some progress has been made. With the code below I've added a Dropdown down box for the months and a scrollbar for the year from the worksheet toolbar. But, I can't get the them to work. All my efforts so far have been in vain. Right now when I try to make the calendar it takes me to the error message at the end of the code Not working correctly! My knowledge in vba is limited and I'm trying to learn more all help will be greatly appreciated! CODE: Sub CalendarMaker() Dim Da As Variant Dim Da2 As Range Dim MyDate 'Backup file located in Module3 this workbook ' Unprotect sheet if had previous calendar to prevent error. ActiveSheet.Protect DrawingObjects:=False, Contents:=False, _ Scenarios:=False ' Prevent screen flashing while drawing calendar. Application.ScreenUpdating = False ' Set up error trapping. On Error GoTo MyErrorTrap ' Clear area a1:g14 including any previous calendar. Range("a1:g14").Clear ' Use InputBox to get desired month and year and set variable '?NOT IN USE? ' MyInput. Da = DropDown2_Change 'InputBox("Type in Month and year for Calendar ") Da2 = Sheet2.Range("i2") ' Allow user to end macro with Cancel in InputBox. If Da = "" Then Exit Sub If Da2 = "" Then Exit Sub ' Get the date value of the beginning of inputted month. StartDay = "=Date(MyDate)" ' Check if valid date but not the first of the month ' -- if so, reset StartDay to first day of month. If Day(StartDay) < 1 Then StartDay = DateValue(Month(StartDay) & "/1/" & _ Year(StartDay)) End If ' Prepare cell for Month and Year as fully spelled out. Sheet1.Range("a1").Value = Da '.NumberFormat = "mmmm" Sheet1.Range("b1").Value = Da2 '.NumberFormat = "yyyy" ' Center the Month and Year label across a1:g1 with appropriate ' size, height and bolding. With Range("a1:b1") .HorizontalAlignment = xlCenterAcrossSelection .VerticalAlignment = xlCenter .Font.Size = 18 .Font.Bold = True .RowHeight = 35 End With ' Prepare a2:g2 for day of week labels with centering, size, ' height and bolding. With Range("a2:g2") .ColumnWidth = 14 .VerticalAlignment = xlCenter .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Orientation = xlHorizontal .Font.Size = 12 .Font.Bold = True .RowHeight = 20 End With ' Put days of week in a2:g2. Range("a2") = "Sunday" Range("b2") = "Monday" Range("c2") = "Tuesday" Range("d2") = "Wednesday" Range("e2") = "Thursday" Range("f2") = "Friday" Range("g2") = "Saturday" ' Prepare a3:g7 for dates with left/top alignment, size, height ' and bolding. With Range("a3:g8") .HorizontalAlignment = xlRight .VerticalAlignment = xlTop .Font.Size = 18 .Font.Bold = True .RowHeight = 21 End With ' Put inputted month fully spelling out into "a1". Sheet1.Range("a1").Value = Da 'Application.Text(MyInput, "mmmm") ' Put inputted year fully spelling out into "b1". Sheet1.Range("b1").Value = Da2 '= Application.Text(MyInput, "yyyy") ' Set variable and get which day of the week the month starts. DayofWeek = Weekday(StartDay) ' Set variables to identify the year and month as separate ' variables. CurYear = Year(StartDay) CurMonth = Month(StartDay) ' Set variable and calculate the first day of the next month. FinalDay = DateSerial(CurYear, CurMonth + 1, 1) ' Place a "1" in cell position of the first day of the chosen ' month based on DayofWeek. Select Case DayofWeek Case 1 Range("a3").Value = 1 Case 2 Range("b3").Value = 1 Case 3 Range("c3").Value = 1 Case 4 Range("d3").Value = 1 Case 5 Range("e3").Value = 1 Case 6 Range("f3").Value = 1 Case 7 Range("g3").Value = 1 End Select ' Loop through range a3:g8 incrementing each cell after the "1" ' cell. For Each cell In Range("a3:g8") RowCell = cell.Row ColCell = cell.Column ' Do if "1" is in first column. If cell.Column = 1 And cell.Row = 3 Then ' Do if current cell is not in 1st column. ElseIf cell.Column < 1 Then If cell.Offset(0, -1).Value = 1 Then cell.Value = cell.Offset(0, -1).Value + 1 ' Stop when the last day of the month has been ' entered. If cell.Value (FinalDay - StartDay) Then cell.Value = "" ' Exit loop when calendar has correct number of ' days shown. Exit For End If End If ' Do only if current cell is not in Row 3 and is in Column 1. ElseIf cell.Row 3 And cell.Column = 1 Then cell.Value = cell.Offset(-1, 6).Value + 1 ' Stop when the last day of the month has been entered. If cell.Value (FinalDay - StartDay) Then cell.Value = "" ' Exit loop when calendar has correct number of days ' shown. Exit For End If End If Next ' Create Entry cells, format them centered, wrap text, and border ' around days. 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 ' Unlock these cells to be able to enter text later after ' sheet is protected. .Locked = False End With ' Put border around the block of dates. 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 ' Turn off gridlines. ActiveWindow.DisplayGridlines = False ' Protect sheet to prevent overwriting the dates. ActiveSheet.Protect DrawingObjects:=True, Contents:=True, _ Scenarios:=False 'True ' Resize window to show all of calendar (may have to be adjusted ' for video configuration). ActiveWindow.WindowState = xlMaximized ActiveWindow.ScrollRow = 1 'Macro Sets Current Day Call DayToGoTo ' Allow screen to redraw with calendar showing. Application.ScreenUpdating = True ' Prevent going to error trap unless error found by exiting Sub ' here. Exit Sub MyErrorTrap: MsgBox "Not Working Correctly!" If Da = "" Then Exit Sub If Da2 = "" Then Exit Sub Resume End Sub Thank you for your help in advance, jfcby |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Select None in dropdown calendar Excel 2003 | New Users to Excel | |||
Calendar change month from multiple sheets to one sheet, Excel 2000 & 2003 | Excel Programming | |||
Excel 2000 scrollbar off-screen and not accessable. How restore? | Excel Discussion (Misc queries) | |||
Modify Yearly Calendar to Monthly Calendar Excel 2000? | Excel Programming | |||
Calendar Control in Excel 2000 can't display date in Excel 2003? | Excel Discussion (Misc queries) |