Automating Outlook Reminders from Excel Table

Rachel Pederson 21 Reputation points

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
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
xOutItem.ReminderSet = False
End If
xOutItem.Body = xRg.Cells(I, 7).Value
xRg = Range("A" & I + 1, "G" & I + 1)
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.


Excel Management
Excel Management
Excel: A family of Microsoft spreadsheet software with tools for analyzing, charting, and communicating data.Management: The act or process of organizing, handling, directing or controlling something.
1,413 questions
0 comments No comments
{count} votes

Accepted answer
  1. Viorel 94,921 Reputation points

    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

1 additional answer

Sort by: Most helpful
  1. Rachel Pederson 21 Reputation points

    Thank you! It is working now.

    0 comments No comments