Criar compromissos de uma lista do Excel no Outlook via VBA

[FabioCosta81 0]

Olá pessoal;

Estou com uma duvida e gostaria de saber se alguém conseguem me ajudar, tenho uma planilha no Excel com diversas datas para pagamento de nota fiscal. Alguém sabe como eu faço para eu gerar que ao clicar no botão o Excel já exporte todos os compromissos para o Outlook?
Eu consegui fazer, porem ele gera o compromisso de apenas uma data por vez (como se fosse uma constante). Eu gostaria que o programa rodasse a coluna de datas e criasse todas as programações que constasse naquela coluna. Vejam o código que eu consegui, porem ele roda apenas uma data. Vejam meus comentarios.

Private Sub CommandButton1_Click()
On Error GoTo Add_Err

Dim objOutlook As Outlook.Application
Dim objAppt As Outlook.AppointmentItem
Dim objRecurPattern As Outlook.RecurrencePattern
Set objOutlook = CreateObject("Outlook.Application")
Set objAppt = objOutlook.CreateItem(olAppointmentItem)
With objAppt
.Start = #11/3/2016 11:15:00 AM# 'Aqui eu gostaria que o programa varresse a coluna e para cada nota criasse um compromisso
.End = #11/3/2016 11:30:00 AM# 'idem ao comentário de cima
.Duration = 30 'duração em minutos 'Gostaria que fosse o dia todo, afinal é só um alerta
.Subject = "Reunião Ricardo" 'Pego essa variavel na linha da nota
.Body = "Mostrar o programa para o Ricardo"
.Location = "Obra"
'Seta o comprimisso para ser lembrado
.ReminderMinutesBeforeStart = 15 'tempo em minutos ' Eu pego o periodo que eu desejo os lembretes na propria planilha
.ReminderSet = True

Set objRecurPattern = .GetRecurrencePattern
'Seta a recorrência da tarefa
'Exclua estas linhas caso não queira uma tarefa recorrente
With objRecurPattern
.RecurrenceType = olRecursWeekly
.Interval = 1
'Uma vez por semana
.PatternStartDate = #11/3/2016# 'Não precisa toda semana
.PatternEndDate = #11/3/2016#
End With
.Save
.Close (olSave)
End With

Set objAppt = Nothing

Set objOutlook = Nothing
Set objRecurPattern = Nothing
MsgBox "Compromisso inserido com sucesso!"
Exit Sub
Add_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub