VBA Cleanup

I have some code that basically loops through a shared outlook calendar and prints out each appointment. I have a list of about 100+ shared calendars to go through. Any ideas on how to make this more efficient. It takes quit a bit of time to run. In my nested for loop, I have the program print out results, is there a better way to do this?

Thanks,
Mike

Sub AssesmentFinder()
Dim Appt As Outlook.AppointmentItem
Dim Items As Outlook.Items
Dim Calendar As MAPIFolder
Dim myStart As Date
Dim myEnd As Date
Dim myCalendar As String
Dim lLastRow As Long
Dim myNamespace As Namespace
Dim myRecipient As Outlook.Recipient
Dim olApp As Outlook.Application

myStart = InputBox("Enter Start Date")
myEnd = InputBox("Enter End Date")

Application.ScreenUpdating = False

For Each row In [tbl_pnName[Practioner_Name]].Rows

Set olApp = New Outlook.Application

myCalendar = row.Value

Set myNamespace = olApp.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient(myCalendar)
myRecipient.Resolve

Set Calendar = myNamespace.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
'Set Calendar = Session.GetDefaultFolder(olFolderCalendar).Folders(myCalendar)
Set Items = Calendar.Items

For Each Appt In Items

If (Appt.Start >= myStart And Appt.End <= myEnd + 1) Then

lLastRow = Sheets("Sheet1").Columns(1).Find("*", SearchDirection:=xlPrevious).row
Sheets("Sheet1").Range("A" & lLastRow + 1).Value = myCalendar
Sheets("Sheet1").Range("B" & lLastRow + 1).Value = UCase(Appt.Subject)
Sheets("Sheet1").Range("C" & lLastRow + 1).Value = UCase(Appt.Location)
Sheets("Sheet1").Range("D" & lLastRow + 1).Value = UCase(Appt.Body)
Sheets("Sheet1").Range("G" & lLastRow + 1).Value = Appt.Start
Sheets("Sheet1").Range("H" & lLastRow + 1).Value = Appt.End
Sheets("Sheet1").Range("I" & lLastRow + 1).Value = Appt.Categories
Sheets("Sheet1").Range("J" & lLastRow + 1).Value = Appt.StartTimeZone

End If

Next Appt

Next row

Sheet1.Activate
ActiveSheet.Cells.WrapText = False

Set Appt = Nothing
Set Items = Nothing
Set Calendar = Nothing
Set myNamespace = Nothing
Set myRecipient = Nothing

Application.ScreenUpdating = True


End Sub