Sub AñadirCitas_a_Calendario_Outlook()
'trasladamos citas desde Excel hacía el Calendario de Outlook

Dim olApp As Object
Dim olNs As Object
Dim olCarpetas As Object, olSubcarpetas As Object
Dim olCalendarios As Object
Dim objCita As Object

Dim sh As Worksheet
Dim i As Long, UF As Long

On Error Resume Next
'Creamos el objeto para la aplicación MS Outlook y abrimos
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0

'determinamos cuál es la última fila con datos
Set sh = Sheets("xlsCalendario")
UF = sh.Cells(sh.Rows.Count, "A").End(xlUp).Row

If Not olApp Is Nothing Then
    'Inicia una sesión de usuario en MAPI
    Set olNs = olApp.GetNamespace("MAPI")
    olNs.LogOn

    'buscamos, con el doble bucle, entre todas las carpetas de Outlook
    'y entre todos los Calendarios existentes el que se llame 'Excelforo'
    For Each olCarpetas In olNs.Folders
        For Each olSubcarpetas In olCarpetas.Folders
        ''''''''
        If olSubcarpetas.Name = "Calendario" Then
        For Each olCalendarios In olSubcarpetas.Folders
             'con el nombre de nuestro Calendario!!
            If olCalendarios.Name = "Excelforo" Then
                'y recorremos todos los datos de la hoja de cálculo
                For i = 2 To UF
                    'Generamos una nueva cita
                    Set objCita = olCalendarios.Items.Add(1)
                    'y la completamos con la info de la hoja en Excel
                    With objCita
                        'el Asunto
                        .Subject = sh.Range("A" & i).Value
                        'la Hora de Inicio
                        .Start = CDate(sh.Range("B" & i).Value) & Chr(32) & CDate(sh.Range("C" & i).Value)
                        'la Hora de finalización
                        .End = CDate(sh.Range("D" & i).Value) & Chr(32) & CDate(sh.Range("E" & i).Value)
                        'el Texto o Cuerpo de la cita
                        .Body = sh.Range("F" & i).Value
                        'la Ubicación de la cita
                        .Location = sh.Range("G" & i).Value
                        'la categoría que le asignamos
                        .Categories = sh.Range("H" & i).Value
                        'Mostrar como: 0-Disponible, 1-Provisional, 2-Ocupado, 3-Fuera de la oficina o 4-Trabajando en otro lugar
                        .BusyStatus = sh.Range("I" & i).Value
                        'si activamos una cita de Todo el día
                        .AllDayEvent = sh.Range("J" & i).Value
                        '.ReminderSet = True        'si queremos tener activa el recordatorio (15 minutos antes, por defecto)
                         .Save   'guardamos la cita
                    End With
                Next i

                'si hemos dado en el bucle con el Calendario buscado
                'salimos de éste (dejamos de buscarlo)
                Exit For
            End If

        Next olCalendarios
        End If
        Next olSubcarpetas
    Next olCarpetas
End If

'liberamos memoria de los objetos definidos
Set olApp = Nothing
Set olNs = Nothing
Set olStore = Nothing
Set olCal = Nothing
Set objAppt = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub