CODEWITHSUNDEEP
vbaexcel-2016appointmentoutlook-2016
kroy2008
kroy2008

Reputation: 175

600 + rows of Excel data to create Outlook Appointment...but only creates a single appointment

Background:

I have a task tracking spread sheet and would like to create a calendar "appointment" everytime a new row is added to the table. There are many instances of different versions of this code floating around out there, so I pieced this together with little true knowledge of VBA.

The Data:

Data is stored in a table (Table1) in Sheet1, which I have renamed "Tracker". It's currently ~600 rows, and ~16 columns. The table is constantly updated with new rows of data.

The Problem:

The macro runs, and loops through the 600+ rows of data, creating an appointment for a row, then overwriting that appointment with the data from the next row. I know it's creating + overwriting b/c I set my calendar view to "list view", and ran the macro...and I can see it cycling through all the different rows, so I know it's looping. So I THINK I need assistance modifying the Private Function's subjectFilter. That said, if I remove the Private Function, it does the same thing.

Right now, the .Subject code is this:

.Subject = Cells(r, 9).Value & " (" & Cells(r, 13).Value & " " & Cells(r, 14).Value & ")"

Although I could simplify it to this if it makes it easier to incorp into the subjectFilter:

.Subject = Cells(r, 9).Value

Questions:

  1. How can I adjust the code so it creates all 600+ appointments?
  2. How do I incorporate my .Subject string into the Private Function's subjectFilter?

Current Code:

Sub SetAppt()

Dim olApp As Outlook.Application 
Dim olApt As AppointmentItem
Dim MySheet As Worksheet

Set MySheet = Worksheets("Tracker")
Set olApp = New Outlook.Application
Set olApt = olApp.CreateItem(olAppointmentItem)

For r = 2 To Cells(Rows.Count,1).End(xlUp).Row

With olApt
       .Start = Cells(r, 2).Value + TimeValue("10:30")
       .Duration = "1"
       .Subject = Cells(r, 9).Value & " (" & Cells(r, 13).Value & " " & Cells(r, 14).Value & ")"
       .Location = Cells(r, 5).Value
       .Body = "Follow up with task lead"
       .BusyStatus = olBusy
       .ReminderMinutesBeforeStart = 60
       .Categories = "Task Reminder"
       .ReminderSet = True
       .Save 

End With
Next

Set olApt = Nothing 
Set olApp = Nothing

End Sub


Private Function Get_Appointment(subject As String) As Outlook.AppointmentItem
'Private Function grabbed from here https://www.google.com/url?sa=t&rct=j&q=&esrc=s&source=web&cd=1&cad=rja&uact=8&ved=0ahUKEwis6IGw7vXXAhXBneAKHWJ9A7kQFggpMAA&url=https%3A%2F%2Fwww.mrexcel.com%2Fforum%2Fexcel-questions%2F686519-using-vba-macro-post-new-appointments-outlook-but-dont-want-duplicates.html&usg=AOvVaw0vUdR7HN9USe52hrOU2M1V

Dim olCalendarItems As Outlook.Items
Dim subjectFilter As String

'Get calendar items with the specified subject
    
subjectFilter = "[Subject] = '" & subject & "'"
Set olCalendarItems = olCalendarFolder.Items.Restrict(subjectFilter)

If olCalendarItems.Count > 0 Then
    Set Get_Appointment = olCalendarItems.Item(1)
Else
    Set Get_Appointment = Nothing
End If
End Function

Upvotes: 2

Views: 325

Answers (1)

Tim Williams
Tim Williams

Reputation: 166331

Use a new appointment object for each row - otherwise you're just creating a single appointment and then updating it repeatedly

Const COL_FLAG As Long = 20 '<< "flag" column
'...
'...
For r = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    'Only create an appointment if not already created....
    If Len(Cells(r, COL_FLAG ).Value)= 0 Then 
    With olApp.CreateItem(olAppointmentItem) '<<< use a new object for each iteration
           .Start = Cells(r, 2).Value + TimeValue("10:30")
           .Duration = "1"
           .Subject = Cells(r, 9).Value & " (" & Cells(r, 13).Value & _
                      " " & Cells(r, 14).Value & ")"
           .Location = Cells(r, 5).Value
           .Body = "Follow up with task lead"
           .BusyStatus = olBusy
           .ReminderMinutesBeforeStart = 60
           .Categories = "Task Reminder"
           .ReminderSet = True
           .Save 
           Cells(r, COL_FLAG ).Value = "Created"
    End With
    End If '<< appt not already created
Next

Upvotes: 1

Related Questions