Automating Outlook Reminders from Excel Table

Question

I have an excel table that contains information to set up a reminder in Outlook.
Columns include Location, Start Date/Time, Duration, Busy Status, Reminder Time, Body, and Created. I have a problem with the code. Every time I run it, it deletes the first row in my table.

Sub AddAppointments()
Dim LastRow As Long
Dim I As Long
Dim xRg As Range
Dim xOutApp As Object
Dim xOutItem As Object
Set xOutApp = CreateObject("Outlook.Application")
Set xRg = Range("A2:G2")
LastRow = Range("A" & Rows.Count).End(xlUp).Row
For I = 1 To LastRow
Set xOutItem = xOutApp.CreateItem(1)
Debug.Print xRg.Cells(I, 1).Value
xOutItem.Subject = xRg.Cells(I, 1).Value
xOutItem.Location = xRg.Cells(I, 2).Value
xOutItem.Start = xRg.Cells(I, 3).Value
xOutItem.Duration = xRg.Cells(I, 4).Value
If Trim(xRg.Cells(I, 5).Value) = "" Then
xOutItem.BusyStatus = 2
Else
xOutItem.BusyStatus = xRg.Cells(I, 5).Value
End If
If xRg.Cells(I, 6).Value > 0 Then
xOutItem.ReminderSet = True
xOutItem.ReminderMinutesBeforeStart = xRg.Cells(I, 6).Value
Else
xOutItem.ReminderSet = False
End If
xOutItem.Body = xRg.Cells(I, 7).Value
xOutItem.Save
xRg = Range("A" & I + 1, "G" & I + 1)
Next
Set xOutApp = Nothing
End Sub

Where did I go wrong?

Also, I want to set a conditional statement so that it only runs the macro on new data so I don't duplicate appointments. Basically, if column H (Created) is yes, then to skip that line and only create an appointment if Column H = nothing.

Thanks!

Answer 1

Try replacing 'xRg = ...' with 'Set xRg = ...'. But this line is not needed. It must be removed.

For the second problem, try adding an If; something like this:

For I = 1 To LastRow
   If LCase(Trim(xRg.Cells(I, 8).Value)) <> "yes" Then
      . . .            
   End If
Next

Answer 2

Thank you! It is working now.