VBA para automatizar Outlook e Excel

[Slovardzen 0]

Galera, sou novo na utilização de VBA e estou tendo um grande problema para conseguir automatizar o Outlook com o Excel. No caso, preciso criar compromissos no calendário do Outlook à partir de dados de uma planilha do Excel que possui 20 colunas e centenas de linhas. Preciso exportar esses dados da planilha para o calendário, primeiro um calendário geral que mostre para todos. Depois, preciso criar compromissos em calendários específicos para cerca de 20 funcionários, podendo este ser expandido para mais contatos.

 

Até agora, tenho conseguido um código mas não tem me retornado da maneira que eu esperava. Estou meio sem saída, tentei fuçar em diversos locais do código, sem sucesso. O código pra inserir um dado por vez eu consigo fazer, o problema é inserir automaticamente os dados. Quando aplico o Loop é que seguem os problemas.

 

Só para explicar, uma das colunas estão as datas que utilizarei como .Start e também como .End, depois configurando AllDayEvent = True. O restante das colunas possui nome do funcioário e setor onde trabalha.

 

Este é o código utilizado para inserir um dado por vez da planilha:

 

Sub SetAppt()

Dim olApp As Object
Dim olApt As Object
Dim olNs As Object
Dim i, j As Integer
Dim usesubject As String

   On Error Resume Next
   Set olApp = GetObject(, "Outlook.Application")

   If Err.Number = 429 Then
   Set olApp = CreateObject("Outlook.application")
   End If

   On Error GoTo 0

   Set olNs = olApp.GetNamespace("MAPI")

   If olApp.ActiveExplorer Is Nothing Then
       olApp.Explorers.Add _
           (olNs.GetDefaultFolder(9), 0).Activate
   Else
       Set olApp.ActiveExplorer.CurrentFolder = _
       olNs.GetDefaultFolder(9) 
       olApp.ActiveExplorer.Display
   End If


   Set olApt = olApp.CreateItem(olAppointmentItem)
   usedate = Cells(1, 2).Value
   usesubject = Cells(2, 2).Value


   With olApt
           .Start = usedate
           .End = usedate
           .Subject = usesubject
           .AllDayEvent = True
           .Body = " "
           .Subject = usesubject
           .Location = " "
           .BusyStatus = olBusy
           .ReminderSet = False
           .Save
   End With

   Set olApt = Nothing
   Set olApp = Nothing
   Set olNs = Nothing
End Sub

 

O problema está quando tento inserir loop pra ler a planilha inteira e necessito criar funções específicas e Subs que não enxergo a saída para tanto. O que eu consegui montar com o que estudei pela net e tirei dúvidas foi isso:

 

Option Explicit

Public olNs As Object

Public Sub CriarCompromisso()
   Dim usarAplicacao As Object
   Dim Inicio As Date
   Dim Fim As Date
   Dim Corpo As String
   Dim Assunto As String
   Dim Ocupado As Integer
   Dim Lembrete As Boolean
   Dim olApp As New Outlook.Application
   Dim olApt As AppointmentItem
       Set olApp = usarAplicacao
       Set olApt = olApp.CreateItem(1)
       With olApt
           .Start = Inicio
           .End = Fim
           .AllDayEvent = True
           .Body = Corpo
           .Subject = Assunto
           .Location = " "
           .BusyStatus = Ocupado
           .ReminderSet = Lembrete
           .Save
       End With

End Sub

Public Function SettarOutlook() As Object
   Dim olApp As New Outlook.Application

       On Error Resume Next
       Set olApp = GetObject(, "Outlook.Application")
       If Err.Number = 429 Then
       Set olApp = CreateObject("Outlook.Application")
       End If

       On Error GoTo 0
       Set olNs = olApp.GetNamespace("MAPI")
       If olApp.ActiveExplorer Is Nothing Then
           olApp.Explorers.Add(olNs.GetDefaultFolder(9), 0).Activate
       Else
           Set olApp.ActiveExplorer.CurrentFolder = olNs.GetDefaultFolder(9)
           olApp.ActiveExplorer.Display
       End If

       Set SettarOutlook = olApp

End Function

Public Sub MoverDados()
   Dim xl As Excel.Worksheet
   Dim c As Integer
   Set xl = ActiveWorkbook.Sheets(1)
   For c = 1 To LastColumn(xl)
       Call CriarCompromisso(SettarOutlook, xl.Cells(1, c), xl.Cells(2, c), xl.Cells(3, c), xl.Cells(4, c), xl.Cells(5, c), xl.Cells(6, c), xl.Cells(7, c), xl.Cells(8, c))
   Next c

End Sub

Public Function LastColumn(Atual As Excel.Worksheet) As Integer
LastColumn = Atual.UsedRange.Columns.Count + Atual.UsedRange.Column - 1
End Function

 

 

Apesar de eu vir aqui pedir uma ajuda, eu gostaria que me dessem uma luz apenas, pois gostaria de descobrir aonde estou errando. Não gostaria de obter o código pronto, de mão beijada. Somente uma luz porque sei que estou errando em muitos lugares mas ainda não entendi toda a lógica da programação. Tenho uma versão comentada dos dois códigos, explicando a maioria das etapas, mas considerei desnecessário colocá-los por enquanto.

 

Qualquer idéia que possa dar uma luz, seria de grande ajuda...

[Slovardzen 0]

Consegui rodar, mas o problema agora está que ele não salva todos os valores do Loop, apenas o último. Alguém sabe de algum comando que eu possa utilizar que salve antes de completar o Loop?