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]

:think:

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:dunno
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! :thumb
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? :rotlaugh:

[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/showpost.php?p=14575&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")

[mvidas]

Neat Richie! I often will add a book then delete all but one sheets, I had no idea there was a better way. Thanks!!

[mdmackillop]

BTW,
Is this another quaint custom in the US of A? :bug:


Range(CLL.Offset(1, 0), CLL.Offset(1, 6)) = Array("S", "M", "T", "W", _
"R", "F", "S")


To make the code transatlantic, how about


If IsDate("31/1/01") Then
'UK Date format
CLL = Format(DateSerial(yr, i, 1), "Mmmm yyyy")
wk = 1
For x = 1 To 31
If IsDate(x & "/" & i & "/" & yr) Then
ddt = DateValue(x & "/" & i & "/" & 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
Else
'US Date format
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
End If

[mvidas]

I'll update my code tomorrow to reflect those changes, but which quaint custom are you referring to? Using R to symbolize Thursday so there aren't two T's, but still using S and S for saturday/sunday? :)

[mdmackillop]

That's the one!

[mvidas]

Eh, I don't even know if thats an American thing or just a me-thing. I usually only use letter abbreviations for weekdays, but since I wanted the full week on this calendar I just used S for the weekend days. I suppose its up to you how you want it, do you just use SMTWTFS in Scotland?

Also, I found an interesting thing in excel

Application.International(xlMDY)
Returns true if the computer uses date format MDY, and false if DMY. (44 can also be used in place of xlMDY). Who knew!
So I added , vDt as String to the Dim statements, and changed our troublesome portion to:

CLL = Format(DateSerial(yr, i, 1), "Mmmm yyyy")
wk = 1
For x = 1 To 31
If Application.International(44) Then vDT = i & "/" & x & "/" & yr Else _
vDT = x & "/" & i & "/" & yr
If IsDate(vDT) Then
ddt = DateValue(vDT)
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 still haven't updated the algorithm for the calendar itself (Ken -- I may end up using a variant of that for a worksheet_doubleclick event to create monthly sheets on demand), but at least the change above will get you DMYers fixed ;)

[Ken Puls]

Eh, I don't even know if thats an American thing or just a me-thing. I usually only use letter abbreviations for weekdays, but since I wanted the full week on this calendar I just used S for the weekend days. I suppose its up to you how you want it, do you just use SMTWTFS in Scotland?

Hey, Matt... you're not trying to impersonate a Canadian there, are you? :rotlaugh:

FYI, I have seen R used for Thursday, back when I was in college. Something along the lines of:

Classes: T 10:00-12:00, R 14:00-16:00

Until now, that's the only place I've ever seen it though.. :yes