Sub envio_mail2()
'Tambien adjunta archivos
'No necesita abrir el Outlook para hacer la macro

Application.ScreenUpdating = False
'On Error GoTo ende

Dim objOutlook As Object
Dim mItem As Object
Dim ruta_archivo As String

  Range("A5").Select
  Range(Selection, Selection.End(xlDown)).Select
  nume_regi = Selection.Count

ruta_archivo = Cells(13, 5).Value
 
 
For i = 1 To nume_regi
' Set OutlookOBJ = CreateObject("Outlook.Application")
' Set mItem = OutlookOBJ.CreateItem(olMailItem)
   
 Enviara = Cells(4 + i, 3)
 asunto = Cells(2, 5)
 Cuerpo = Cells(5, 5)
 empresa = Cells(4 + i, 2)
 persona = Cells(4 + i, 1)

 With mItem
    .To = Enviara
    .Subject = asunto & " para " & empresa
    .Body = "Hola " & persona & vbCrLf & vbCrLf & Cuerpo & vbCrLf & vbCrLf & "Saludos Cordiales"
    '.Send
 End With
 
 If ruta_archivo <> "" Then
    With mItem
    .Attachments.Add (ruta_archivo)
    End With
 End If
 
    With mItem
    .Send
    End With
 
 
Next i

Range("A5").Select

Application.ScreenUpdating = True
Set OutlookOBJ = Nothing
Set mItem = Nothing

MsgBox ("Finalizado se enviaron " & nume_regi & " Correos con exito")
Exit Sub

ende:
MsgBox "no se mandaron los correos verificar informacion"

End Sub