Thank you for looking at my question. I am fairly new to VBA. I am trying to import appointments from
Excel 2010 to Outlook 2010 using the code below. Running the code does not generate any errors but the appointments go into my default calendar rather than the calendar named "Smith".
Please let me know how to populate the correct calendar. The calendar "Smith" is not yet shared and I do not have (or want) a contact for it. I work in an office with 13 people. Each person has a worksheet in a spreadsheet that they update every 2 weeks. From there I import what they are working on as appointments into a calendar so the boss can see (month by month) what project each person is working on. This way when he gets a call requesting someone do something he can look at the calendar and see what impact that will have. He can also look at or overlap people's calendars to determine if someone else might have a better schedule to accommodate the request.
I started by modifying the code in the following link.
http://www.outlookcode.com/threads_print.aspx?forumid=1&messageid 775
Thank you for your help and time. - Jin
Excel 2010 to Outlook 2010 using the code below. Running the code does not generate any errors but the appointments go into my default calendar rather than the calendar named "Smith".
Please let me know how to populate the correct calendar. The calendar "Smith" is not yet shared and I do not have (or want) a contact for it. I work in an office with 13 people. Each person has a worksheet in a spreadsheet that they update every 2 weeks. From there I import what they are working on as appointments into a calendar so the boss can see (month by month) what project each person is working on. This way when he gets a call requesting someone do something he can look at the calendar and see what impact that will have. He can also look at or overlap people's calendars to determine if someone else might have a better schedule to accommodate the request.
I started by modifying the code in the following link.
http://www.outlookcode.com/threads_print.aspx?forumid=1&messageid 775
Thank you for your help and time. - Jin
Code:
Dim exlWkb As Workbook
Dim exlSht As Worksheet
Dim rng As Range
Dim itmAppt As Outlook.AppointmentItem
Dim aptPtrn As Outlook.RecurrencePattern
Dim strFilePath As String
Dim iRow As Integer
Dim iCol As Integer
Dim tmpItm As Outlook.Link
Dim mpiFolder As MAPIFolder
Dim oNs As Outlook.Namespace
Dim Ldate As Date
Dim LTime As Date
Dim k As Integer
Dim Rsrc As Long
Dim n As Integer
Dim sStr As String
Dim j As Integer
n = 0
j = 7
k = 0
Set exlWkb = ThisWorkbook
Set exlSht = exlWkb.Worksheets(27)
Sheets(27).Select
Sheets(27).Activate ' make the sheet active
ActiveSheet.Range("A3").Select
Selection.CurrentRegion.Select ' Selects the current data area.
Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Select ' Selects the current data area without the top two rows.
Rsrc = Rsrc + Selection.Rows.Count
sStr = ""
Set oNs = Outlook.GetNamespace("MAPI")
iRow = 3
For n = 1 To Rsrc
Set mpiFolder = oNs.GetDefaultFolder(olFolderCalendar).Folders("Smith")
Set itmAppt = Outlook.CreateItem(olAppointmentItem)
Set aptPtrn = itmAppt.GetRecurrencePattern
If IsNull(exlSht.Cells(iRow, 6)) Or exlSht.Cells(iRow, 6) = "" Then
' no start date provided
Else
With itmAppt
Ldate = exlSht.Cells(iRow, 6)
If n = 1 Then
LTime = TimeSerial(j, k, 0)
Else
LTime = LTime + TimeValue("00:15")
End If
.Start = Ldate & " " & LTime
sStr = ""
If IsNull(exlSht.Cells(iRow, 8)) Or exlSht.Cells(iRow, 8) = "" Then
sStr = "no end date"
.NoEndDate = True
ElseIf exlSht.Cells(iRow, 6) = exlSht.Cells(iRow, 8) Then
.AllDayEvent = True
Else
' .EndTime = exlSht.Cells(iRow, 7) ' H Due Date
.End = exlSht.Cells(iRow, 8)
End If
If IsNull(exlSht.Cells(iRow, 12)) Or exlSht.Cells(iRow, 12) = "" Then
If sStr = "no end date" Then
.Subject = "no task name; no end date"
Else
.Subject = "no task name"
End If
Else
If sStr = "no end date" Then
.Subject = exlSht.Cells(iRow, 12) & " - " & sStr
.Subject = exlSht.Cells(iRow, 12) 'L
Else
.Subject = exlSht.Cells(iRow, 12)
End If
End If
If Not IsNull(exlSht.Cells(iRow, 5)) And exlSht.Cells(iRow, 5) <> "" Then
If exlSht.Cells(iRow, 5) = "continuous" Then
aptPtrn.RecurrenceType = olRecursDaily
ElseIf exlSht.Cells(iRow, 5) = "Weekly" Then
aptPtrn.RecurrenceType = olRecursWeekly
ElseIf exlSht.Cells(iRow, 5) = "Monthly" Then
aptPtrn.RecurrenceType = olRecursMonthly
' ElseIf exlSht.Cells(iRow, 5) = "bimonthly" Or exlSht.Cells(iRow, 5) = "bi-monthly" Then
'apparently not an option
ElseIf exlSht.Cells(iRow, 5) = "Annual" Or exlSht.Cells(iRow, 5) = "Annually" Or exlSht.Cells(iRow, 5) = "Yearly" Then
aptPtrn.RecurrenceType = olRecursYearly
End If
End If
.ReminderSet = False
End With
itmAppt.Save
End If
iRow = iRow + 1
Next n
Set exlSht = Nothing
