Excelden Outlook toplantı verilerini Aktarma

Sub Outlook_Takvime_Gonder()
    Dim EvnOUT As Object, OutRandevu As Object, say As Long
    say = 0
    For s = 3 To Range("C65536").End(xlUp).Row
    If Cells(s, "B") <> "OK" Then
    
    On Error Resume Next
    Set EvnOUT = GetObject(, "Outlook.Application")
    If Err.Number = 429 Then
        Set EvnOUT = CreateObject("Outlook.application")
    End If
    On Error GoTo 0
    Set OutRandevu = EvnOUT.CreateItem(1)
    On Error Resume Next
        With OutRandevu
            .Start = Cells(s, "C") + Cells(s, "D")
            .End = Cells(s, 5) + Cells(s, 6)
            .Subject = Cells(s, 7)
            .Location = Cells(s, 8)
            .Body = Cells(s, "I")
            If Len(Cells(s, "J")) > 0 Then
                If IsNumeric(Cells(s, "J")) Then
                    .ReminderMinutesBeforeStart = Cells(s, "J")
                    .ReminderSet = True
                End If
            End If
            If Err <> 0 Then
                Cells(s, "B") = "HATA"
            Else
                .Save
                Cells(s, "B") = "OK"
                Err = 0
                say = say + 1
            End If
        End With
    

    Set EvnOUT = Nothing
    Set OutRandevu = Nothing
    End If
    Next s
    If say > 0 Then
        MsgBox say & " adet kayıt aktarıldı.", vbInformation
    Else
        MsgBox "Aktarılan kayıt yok!", vbExclamation
    End If
End Sub

Örnek excel_dosyası indir