VBA CODE FOR ALL THE MACROS IN KITTY'S GREAT CALENDAR PROJECT

(NOTE: Anything written outside of the Sub/EndSub lines is commentary and not part of a macro.)

I've included all of the macros we used to produce The Calendar. You should be able to cut and paste them into a module in an Excel worksheet. You might find it easier to right-click on the link MacroCode and download a cleaner version of the plain text.

I also tried to add enough comments to make it clear what elements can or should be changed to allow this to be installed on someone else's system.

I'm obviously not a VBA expert but if you encounter problems, you can e-mail me via webmaster@kittytours.org and I'll try to help out.

Better yet, join Experts Exchange (www.experts-exchange.com) and ask the experts. They are worth every penny of your membership fee.

Sub SaveMyFile()
'This version of the SaveMyFile macro was written by EE expert byundtd
'This macro saves a copy of the active sheet as a new workbook "ExcelCalendar.xls".
'You can change the name of the file in line six if you need to.
'It doesn't change name of existing workbook.
'
Dim ws As Worksheet
Application.ScreenUpdating = False

Set ws = ActiveSheet
ws.Copy
ws.Cells.Copy ActiveSheet.Cells(1, 1)

ActiveWorkbook.SaveAs "ExcelCalendar.xls"
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub



Sub ReplaceApos()
'This macro was written by EE expert bruintje
'It loops through every cell in columns A, C, and E and
'converts the value of the cell to its non-text equivalent
'
Dim C As Range
Dim icol As Integer
'This macro converts text in Cols A, C, and E to date or time data
'we need to run through cols a,c,e that is 1,3,5
For icol = 1 To 5
If icol = 1 Then
For Each C In Range(Cells(2, icol), Cells(65536, icol).End(xlUp))
C.Value = C.Value
Next
End If
If icol = 3 Then
For Each C In Range(Cells(2, icol), Cells(65536, icol).End(xlUp))
C.Value = C.Value
Next
End If
If icol = 5 Then
For Each C In Range(Cells(2, icol), Cells(65536, icol).End(xlUp))
C.Value = C.Value
Next
End If
Next
End Sub


Sub KillB()
'This macro was written by EE expert brettdj
'This macro deletes all Lunch appointments
'It searches each cell in Column B for the string Lunch
'When it finds Lunch, it deletes the entire row
'
Dim Myrange As Range, DelRange As Range, C As Range
Dim FirstAddress As String

Set Myrange = Intersect(ActiveSheet.UsedRange, Columns("B"))
If Myrange Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Set C = Myrange.Find("Lunch", Myrange.Cells(1), xlValues, xlWhole)
If Not C Is Nothing Then
Set DelRange = C
FirstAddress = C.Address
Do
Set C = Myrange.FindNext(C)
Set DelRange = Union(DelRange, C)
Loop While FirstAddress <> C.Address
End If
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
Application.ScreenUpdating = True
End Sub


Sub GetDate()
'This macro was written by EE expert brettdj
'This macro inserts empty dates for six months
'NOTE: The active cell (cursor location) should be the first empty cell after your data
'Otherwise, it will write over existing data
'Use macro EmptyA first to move the cursor
'
Dim sDate As Date, Myrange As Range, NumCels As Integer
sDate = InputBox("Enter start date", Default:=Format(Now(), "dd-mmm-yyyy"))
If IsDate(sDate) Then
ActiveCell = sDate
NumCels = DateSerial(Year(sDate), Month(sDate) + 6, Day(sDate)) - sDate
Set Myrange = ActiveCell.Resize(NumCels, 1)
Selection.AutoFill Destination:=Myrange, Type:=xlFillDefault
Else
MsgBox "Input was not a date", vbCritical
End If
ActiveSheet.Range("a1").Select
End Sub



Sub DeleteFakeTimes()
'This macro was written by EE expert roos01
'This macro deletes fake midnights inserted by Outlook
'It looks for cells in which the value is zero and replaces those with an empty string
'Excel recognizes zero as midnight in time data
Application.ScreenUpdating = False
RowsA = ActiveSheet.UsedRange.Rows.Count
For i = 1 To RowsA

If Cells(i, 3).Value = 0 And Cells(i, 5).Value = 0 Then
Cells(i, 3).Value = ""
Cells(i, 5).Value = ""
End If
Next i
Application.ScreenUpdating = True

End Sub


Sub CompareDates()
'This macro was written by EE expert MalicUK
'This macro deletes empty dates if a real appointment already exists
Dim i As Long
i = 1

While Cells(i, 1).Value <> ""
If Cells(i, 1).Value <> "" And Cells(i, 2).Value = "" Then
While Cells(i + 1, 1).Value = Cells(i, 1).Value
If Cells(i + 1, 2).Value = "" Then
Cells(i + 1, 2).EntireRow.Delete
End If
Wend
If Cells(i - 1, 1).Value = Cells(i, 1).Value And Cells(i - 1, 2).Value <> "" Then
Cells(i, 1).EntireRow.Delete
Else
i = i + 1
End If
Else
i = i + 1
End If
Wend
ActiveSheet.Range("a1").Select

End Sub



Sub EmptyA()
'This macro was written by EE expert roos01
'This macro searches for the first empty cell in Column A and moves the cursor to it
Range("A1").End(xlDown).Offset(1, 0).Select
End Sub


Sub SortDateTime()
'This macro was written by EE expert jevreist
'This macro selects all the data
'It then sorts by date (treating months as dates) and time

Dim ws As Worksheet, rng As Range
Set ws = ActiveSheet
Set rng = ws.Range(Cells(1, 1), Cells(ws.UsedRange.Rows.Count, 6))
rng.Sort key1:=ws.Cells(1, 1), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=5, MatchCase:=False, Orientation:=xlTopToBottom
End Sub



Sub SuperMacro()
'This macro was written by EE expert DRJ
'This macro just calls the other macros in order
'If you changed the name of the file saved in SaveMyFile
'You should change the file name in the first message box
'
Call ReplaceApos
Call KillB
Call EmptyA
Call GetDate
Call SortDateTime
Call DeleteFakeTimes
Call SortDateTime
Call CompareDates
Call SortDateTime
Call ForgetThePast
Call SaveMyFile
Call CloseEmAll

MsgBox "Your data has now been cleaned and saved as ExcelCalendar.xls"
MsgBox "Close Excel now to return to Access"
MsgBox "Don't save changes when Excel asks"

End Sub



Sub SaveMyFileOld()
'This macro was written by EE expert DRJ
'This macro automatically saves the cleaned data as ExcelCalendar.xls
'Uses the same path as the active workbook
'This macro is not used in Kitty's Great Calendar Project but it's useful code
'So I kept it
'Note: it will ask the user if it's okay to replace the old file. Answer is Yes.

'ActiveWorkbook.SaveAs ThisWorkbook.Path & "\ExcelCalendar.xls"

'End Sub



Sub ImportCalendarData()

'Produced by Kitty using Record A Macro in Excel Tools
'This macro automatically imports the calendar data exported by Outlook
'To the file CurrentCalendarData
'NOTE: There are three instances of the file name and path
'If you use a different file name or a path other than C:\ you need to change that code

With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data
Source=C:\CurrentCalendarData.xls;Mode=Share Deny Write;Extended " _
, _
"Properties=""HDR=YES;"";Jet OLEDB:System database="""";Jet
OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:Engine Ty" _
, _
"pe=35;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk
Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLEDB:New D" _ ,
_ "atabase Password="""";Jet OLEDB:Create System Database=False;Jet
OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale on Compa" _
, "ct=False;Jet OLEDB:Compact Without Replica Repair=False;Jet
OLEDB:SFP=False") _ , Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("Calendar")
.Name = "CurrentCalendarData"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\CurrentCalendarData.xls"
.Refresh BackgroundQuery:=False
End With
End Sub



Sub ForgetThePast()
'This macro was written by EE expert brettdj
'It deletes every row for which the date is today or earlier
Dim Myrange As Range
Rows(1).Insert
Range("A1:B1") = "Dummy"
Set Myrange = Intersect(ActiveSheet.UsedRange, Columns("A"))
If Myrange Is Nothing Then Exit Sub
Application.ScreenUpdating = False
With Myrange
.Offset(0, 1).Columns.Insert
.Offset(0, 1).FormulaR1C1 = "=IF(AND(ISNUMBER(RC[-1]),RC[- 1]<=NOW()),""kill"","""")"
.Offset(0, 1).AutoFilter Field:=1, Criteria1:="kill"
.EntireRow.Delete Shift:=xlUp
.Offset(0, 1).Columns.Delete
End With
ActiveSheet.Range("a1").Select
Application.ScreenUpdating = True

End Sub



Sub CloseEmAll()
'This macro was copied by Kitty from an example in
'Microsoft Developers Network help
'It closes all the open workbooks except the current workbook
For Each w In Workbooks
If w.Name <> ThisWorkbook.Name Then
w.Close savechanges:=True
End If
Next w

End Sub