Need to loop Macro for an entire list of data

[robexcelnewbie]

Hello! I'm new to this forum. I have the following code but it only works for the first line of data and I need it to loop through an entire list of data. Can someone show me what I need to add to have a loop work?

Sub Appointments()



Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object


On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0


If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon


Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.subject = Range("A2").Value
OLAppointment.Start = Range("B2").Value
OLAppointment.ReminderMinutesBeforeStart = Range("C2").Value
OLAppointment.Save

Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing


End If

End Sub

 

[tweedle]

Greetings Rob, Welcome to the forum.

Your solution looks something like this

[COLOR=#0000cd]Dim r As Long 'Row Counter[/COLOR]
[COLOR=#0000cd]For r = 2 To ActiveSheet.UsedRange.Columns(1).Cells.Count - 1 'Row 2 to the end of Used Range[/COLOR]


    Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
    OLAppointment.Subject = Cells(r, 1).Value
    OLAppointment.Start = Cells(r, 2).Value
    OLAppointment.ReminderMinutesBeforeStart = Cells(r, 3).Value
    OLAppointment.Save


[COLOR=#0000cd]Next r [/COLOR]

 

[robexcelnewbie]

thank you tweedle! I used what you posted to replace piece of my original code (shown in blue below). Whwn I ran the macro it made several blank reservations. It didn't pull the data from the spreadsheet (cells A2, B2 and C2) Should I enter your code in a different place?

Sub Appointments()



Const olAppointmentItem As Long = 1
Dim OLApp As Object
Dim OLNS As Object
Dim OLAppointment As Object


On Error Resume Next
Set OLApp = GetObject(, "Outlook.Application")
If OLApp Is Nothing Then Set OLApp = CreateObject("Outlook.Application")
On Error GoTo 0


If Not OLApp Is Nothing Then

Set OLNS = OLApp.GetNamespace("MAPI")
OLNS.Logon

Dim r As Long 'Row Counter
For r = 2 To ActiveSheet.UsedRange.Columns(1).Cells.Count - 1 'Row 2 to the end of Used Range


Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.subject = Cells(r, 1).Value
OLAppointment.Start = Cells(r, 2).Value
OLAppointment.ReminderMinutesBeforeStart = Cells(r, 3).Value
OLAppointment.Save




Next r
Set OLAppointment = Nothing
Set OLNS = Nothing
Set OLApp = Nothing


End If

End Sub

 

[tweedle]

Nope. That's the right place.
Do you have data anywhere below where you have the items to be scheduled? That would cause UsedRange to extend beyond actual entries.

Here's a slightly different version to get that last row in Column A. (It assumes however that listed items will be contiguous down the column; otherwise it will miss anything after a blank in Col A.)

Dim r As Long 'Row Counter
Dim lr As Long ' Last Row


With ActiveSheet
    lr = .Cells(1, 1).End(xlDown).Row
End With


For r = 2 To lr 'Row 2 to the end of Range


Set OLAppointment = OLApp.CreateItem(olAppointmentItem)
OLAppointment.Subject = Cells(r, 1).Value
OLAppointment.Start = Cells(r, 2).Value
OLAppointment.ReminderMinutesBeforeStart = Cells(r, 3).Value
OLAppointment.Save


Next r