Looping and Filtering in VBA

[southcali12]

Hi Everyone,

I am sending out Outlook appointments via a spreadsheet where all the data/information is stored. However, the issue I am running into is: when I need to send out multiple information to the same email address for a client, I want the client to get all of the information in the one appointment's body, and not send out out X amount of emails to the same client with different information.

For example in the sample below, I'd want the rows with Alaska-5 to be sent in one appointment body, and the row with Alaska-6 to be sent in another appointment body.

Example of what spreadsheet looks like (the other columns are filled with other information):

Column D	Column G	Column H	Column I	Column K	Column N	Column O	Column P	Column Q
Site	Client	Supervisor	Date	Client Time	Client Ticket	Site Email	Appointment Start	Phone Number
Alaska-5	Doe,John	Adam,Joe	11/8/2015	1500	123456	Alaska-5@123.com	11/8/2015 15:00	(800)123-4567
Alaska-6	Smith,Mary	Smith,John <tbody> </tbody>	11/8/2015 <tbody> </tbody>	1900 <tbody> </tbody>	3456789	Alaska-6@123.com	11/8/2015 15:30	(800)123-4567
Alaska-5	White,Betty	Adam,Joe	11/8/2015 <tbody> </tbody>	1530 <tbody> </tbody>	564897	Alaska-5@123.com	11/8/2015 17:00	(800)123-4567

<tbody>
</tbody>

Code:
Sub SetAppt()
'Want it to filter by site and hour, and send out one appointment per site/hour
Dim olApt As Object
Dim olApp As Object
Dim i As Long
Dim apptRange As Variant

Const olAppointmentItem As Long = 1
Set olApp = GetOutlookApp

' read appts into array
apptRange = Range(Cells(2, 1), Cells(Rows.Count, 17).End(xlUp)).Value

For i = LBound(apptRange) To UBound(apptRange)
Set olApt = olApp.CreateItem(olAppointmentItem)
With olApt
.RequiredAttendees = apptRange(i, 15)
.Start = apptRange(i, 16)
.Duration = "60"
.Subject = "Subject"
.body = "Hello " & apptRange(i, 4) & "," & vbCrLf & vbCrLf & "Looking forward to speaking with you:" & vbCrLf & vbCrLf & _
"Client: " & vbCrLf & "Time: " & apptRange(i, 10) & vbCrLf & "Date: " & apptRange(i, 9) & vbCrLf & vbCrLf & _
"Phone Number: " & apptRange(i, 17) & vbCrLf & vbCrLf & _
.BusyStatus = olBusy
.ReminderMinutesBeforeStart = "30"
.ReminderSet = True
.Importance = olImportanceHigh
.display
End With

Next

End Sub
Function GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = CreateObject("Outlook.Application")
End Function

 

[CharlesChuckieCharles]

sorting the data by site and hour as a start would be useful

Then just track that changes in the values that matter to you

ThisSite=""
ThisHour=""

For i = LBound(apptRange) To UBound(apptRange)
If ThisSite<>apptRange(i,4) or ThisHour<> apptRange(i,15) and ThisSite<>"" then 
.display  ' as in send the appointment
ThisSite=apptRange(i,4)
ThisHour = apptRange(i,15)
endif
now start processing the next appointment

at the end after the loop

.display to send the last email