Envío masivo de outlook por medio de macros de excel.

Necesito ayuda necesito enviar varios mails por medio de una macro de excel ya tengo algo avanzado pero me marca error de variable y después al adjuntar un archivo tbn marca error, espero y me puedas ayudar, te anexo los datos de lo que llevo en la macro:
Public Sub SendMail()
'On Error GoTo Err_SendMail
    Dim objOutlook As Outlook.Application
    Dim objSession As Outlook.Namespace
    Dim objMessage As Outlook.MailItem
    Dim objRecipient As Object
    Dim sArchivo As String
    Dim sCorreo As String
    'El ciclo inicia con el número de la fila
    For I = 1 To 5 'Depende del número de destinatarios
        Set objOutlook = CreateObject("Outlook.Application")
        Set objSession = objOutlook.GetNamespace("MAPI")
        Set objMessage = objOutlook.CreateItem(olMailItem)
        sCorreo = Range("B" & I).Value
        Set objRecipient = objSession.CreateRecipient(sCorreo)
        objSession.Logon
        objMessage.Recipients.Add (objRecipient)
        objMessage.Subject = "Titulo hoja"
        objMessage.Body = Range("A" & I).Value & vbNewLine & _
                          Range("C" & I).Value & vbNewLine & _
                          "texto que necesitemos"    
        sArchivo = ActiveWorkbook.Path & "archivo adjunto.pdf"
        objMessage.Attachments.Add (sArchivo)
        objMessage.Send
        objSession.Logoff
    Next I
    objMessage.Display
    MsgBox "Mensajes enviados exitosamente!"
    Set objRecipient = Nothing
    Set objOutlook = Nothing
    Set objSession = Nothing
    Set objMessage = Nothing
Exit_SendMail:
    Exit Sub
Eerr_SendMail:
    MsgBox "Excepción encontrada " & Err.Description & " Originada por " & Err.Source, vbInformation, Application.Name
    Resume Exit_SendMail
End Sub