Code review?

[mvidas]

Hi Everyone,

I made a macro that will create a landscape-style calendar for a given year (chosen at runtime). I'd love any suggestions/improvements/ideas about it. Written in excel 2000, will be given to different versions. After it's done I'll add it as a KB entry too.
Any thoughts are appreciated!

Sub CreateCalendar()
 Dim Mos As Range, CLL As Range, ddt As Date
 Dim wk As Integer, i As Integer, yr As Long, x As Integer
 yr = Application.InputBox(Prompt:="Please enter the 4 digit year", _
  Title:="Enter year", Default:=Year(Now), Type:=1)
 Application.ScreenUpdating = False
 Workbooks.Add
 Application.DisplayAlerts = False
 For i = Application.SheetsInNewWorkbook To 2 Step -1
  Sheets(i).Delete
 Next i
 Application.DisplayAlerts = True
 Range("A1:AE26").Font.Size = 12
 Range("A:G,I:O,Q:W,Y:AE").ColumnWidth = 3.71
 Range("H:H,P:P,X:X").ColumnWidth = 1
 Range("1:8,10:17,19:26").RowHeight = 24.75
 Range("9:9,18:18").RowHeight = 9
 Set Mos = Union([A1], [i1], [q1], [y1], [A10], [i10], [q10], [y10], _
  [a19], [i19], [q19], [y19])
 i = 1
 Mos.NumberFormat = "@"
 Mos.Font.Bold = True
 For Each CLL In Mos.Cells
  Range(CLL, CLL.Offset(0, 6)).HorizontalAlignment = 7
  Range(CLL, CLL.Offset(7, 6)).BorderAround (1)
  Range(CLL.Offset(1, 0), CLL.Offset(7, 6)).HorizontalAlignment = -4108
  Range(CLL.Offset(1, 0), CLL.Offset(1, 6)) = Array("S", "M", "T", "W", _
   "R", "F", "S")
  Range(CLL.Offset(1, 0), CLL.Offset(1, 6)).Borders(9).LineStyle = 1
  CLL = Format(DateValue(i & "/1/" & yr), "Mmmm yyyy")
  wk = 1
  For x = 1 To 31
   If IsDate(i & "/" & x & "/" & yr) Then
    ddt = DateValue(i & "/" & x & "/" & yr)
    If x > 1 And Weekday(ddt) = 1 Then wk = wk + 1
    CLL.Offset(wk + 1, Weekday(ddt) - 1) = Day(ddt)
   End If
  Next x
  i = i + 1
 Next CLL
 With ActiveSheet.PageSetup
  .LeftMargin = Application.InchesToPoints(0.25)
  .RightMargin = Application.InchesToPoints(0.25)
  .TopMargin = Application.InchesToPoints(0.25)
  .BottomMargin = Application.InchesToPoints(0.25)
  .CenterHorizontally = True
  .CenterVertically = True
  .Orientation = xlLandscape
  .PaperSize = xlPaperLetter
  .Zoom = False
  .FitToPagesWide = 1
  .FitToPagesTall = 1
 End With
 ActiveSheet.Name = Format(ddt, "yyyy")
 Application.ScreenUpdating = True
End Sub

Matt

[Ken Puls]

Thanks Matt! I needed a new calendar!

Works on 97 and 2003, although I only tested the printing in 2003. I wasn't expecting it to make a new book, but it's probably a good idea.

I'll see if any other thoughts come up and post back if they do.

Cheers,

[mvidas]

I appreciate it! I made it a new book as I'm going to be creating an add-in out of this, and don't want to have to worry about overwriting someones work or checking for an activeworkbook, etc
I thought about asking for a span of years and creating a tab for each one, but i couldn't think of a time that would really be necessary, and would confuse more people than help, probably. Still looking for new features though, possibly creating a tab for each month of the year, will room to write information/etc? Think that could be useful?

[Ken Puls]

Could be... don't know really, as it depends on the end user, really.

You know, J-Walk had something in one of his books on using an array to make a monthly calendar... I'll see if I can locate it tonight.

[mdmackillop]

Hi Matt,
I must have a different 2003 from Ken, haven't had a chance to look at the code, but here's the result
MD

[mvidas]

Wow thats pretty cool
Strange that it would do that though. I think I have office xp and office 97 on cds around here, I just keep it on 2000 as thats what i have at work. Im sure I can install them all separately, but just havent done it yet.
How odd that it would do that to the months and days

[Paleo]

Hi Malcolm,

I got the same result (using 2003 also) plus an error when setting the paper size. Could it be a difference because of language settings???

[Paleo]

For testing I have changed it from

.PaperSize = xlPaperLetter 
to
.PaperSize = 70

No error, but same result.

[Ken Puls]

Wow thats pretty cool ....How odd that it would do that to the months and days

I think I may have an idea what happened here... Could be wrong, but look at this part of your code:

For x = 1 To 31
               If IsDate(i & "/" & x & "/" & yr) Then
                  ddt = DateValue(i & "/" & x & "/" & yr)
                  If x > 1 And Weekday(ddt) = 1 Then wk = wk + 1
                  CLL.Offset(wk + 1, Weekday(ddt) - 1) = Day(ddt)
               End If
           Next x

I use the American date format on my machine MM/DD/YYYY. I'm willing to bet that neither Malcolm nor Carlos do though! And I'm also pretty sure that the ISDate function might get confused in this circumstance, too.

Not knowing the exact date format they'd use, I just tried flipping your i's and x's around. While it didn't produce Malcolm's output exactly, it was similar.

[mdmackillop]

You could be right Ken, we which is the correct way to write the date over here!
MD

[mvidas]

Good call, Ken!
Hmmm, I thought about using the dateserial function, but I don't trust it (put dateserial(2005,2,30) and it comes back as march 2, 2005)

OK, try changing the For x loop to:

For x = 1 To 31
   If TheDate(yr, i, x) <> "Error" Then
    ddt = TheDate(yr, i, x)
    If x > 1 And Weekday(ddt) = 1 Then wk = wk + 1
    CLL.Offset(wk + 1, Weekday(ddt) - 1) = Day(ddt)
   End If
  Next x

and add at the bottom:

Public Function TheDate(ByVal vYear As Integer, ByVal vMonth As Integer, _
  ByVal vDay As Integer)
 Dim NumDays As Integer
 Select Case vMonth
  Case 1, 3, 5, 7, 8, 10, 12
   NumDays = 31
  Case 2
   If vYear Mod 4 = 0 Then
    If vYear Mod 100 = 0 And vYear Mod 400 <> 0 Then NumDays = 28 Else NumDays = 29
   Else
    NumDays = 28
   End If
  Case 4, 6, 9, 11
   NumDays = 30
  Case Else
   NumDays = 0
 End Select
 If vDay > NumDays Then TheDate = "Error" Else TheDate = DateSerial(vYear, vMonth, vDay)
End Function

Seems like a bad way to do it but I can't think of a better way..

[HalfAce]

Hi Matt,
Your original code worked great for me too using 2003 & American date format.

Pretty handy routine to have laying around!

Dan

[mvidas]

Thanks Dan,
Your posting just reminded me I left this thread open. I'm not quite done with the routine yet, but Ken gave me a lot to think about in an email he sent me. I'll close this one out, and add the KB entry when I get it finished (I'll post a link to the entry from here in case anyone is curious).
Matt

[mdmackillop]

Hi Matt,
I was just looking at your code. This line needs tweaking

CLL = Format(DateValue(i & "/1/" & yr), "Mmmm yyyy")

to

CLL = Format(DateValue("1/" & i & "/" & yr), "Mmmm yyyy")

for the UK calender, otherwise every month is January... and I prefer the summer months.
MD

[Ken Puls]

... and I prefer the summer months.

So... you want him to make it so every month is July then?

[mvidas]

Haha Malcolm, I was trying to appease the Southern Hemisphere users, January is summer!

There is a temporary fix at http://www.vbaexpress.com/forum/show...5&postcount=11 for the non-american users, but I'm hoping to work around that

[mdmackillop]

Seems good to me. I can take my holidays then!

[mdmackillop]

Hi Matt,
I used that fix, but it wasn't catching the heading to each month.
Malcolm

[Richie(UK)]

Hi,

Just a quickie (said the actress to the bishop) - you can add a workbook with a single sheet rather than adding a standard one and then deleting sheets. Like this :

Set wbk = Workbooks.Add(xlWBATWorksheet)

[mvidas]

Ahhh, I forgot all about that. You can fix it with:

'  CLL = Format(DateValue(i & "/1/" & yr), "Mmmm yyyy")
  CLL = Format(DateSerial(yr, i, 1), "Mmmm yyyy")