Macro para seleccionar varias celdas y enviar por correo electrónico .

Para: Dante Amor.

Buenas noches por favor su valiosa ayuda. Requiero una macro para seleccionar un rango de celdas y posterior a esto enviar a un correo electronico; esto lo necesito para enviar boletas de pago del personal y así no imprimir y gastar papel y contribuir con el planeta.

Encontré la macro que detallo en la parte de abajo, la cual funciona correctamente, pero quiero que la misma macro luego me seleccione otro rango y me envié a otro correo al mismo tiempo, he copiado las mismas instrucciones y solamente he cambiado lo siguiente: correo = Range("d24").Value ; Range("c22:f40"). Copy, pero no me ha funcionado.

Favor su ayuda.

Sub correo_Macro2()

Dia = Range("i2").Value
Mes = Range("j2").Value
correo = Range("d3").Value
Range("c7:f21").Copy
Set parte1 = CreateObject("outlook.application")
Set parte2 = parte1.createitem(olmailitem)
parte2.to = correo
parte2.Subject = "ROL DE PAGOS " & Mes & " " & Dia
parte2.display
Application.SendKeys "^v", True
DoEvents
Application.Wait Now + TimeValue("00:00:01")
DoEvents
parte2.send
Set parte1 = Nothing
Set parte2 = Nothing
End Sub

2 Respuestas

Respuesta
1

Prueba así:

Sub correo_Macro2()
    Dia = Range("i2").Value
    Mes = Range("j2").Value
    correo = Range("d3").Value
    Range("c7:f21").Copy
    Set parte1 = CreateObject("outlook.application")
    Set parte2 = parte1.createitem(olmailitem)
    parte2.to = correo
    parte2.Subject = "ROL DE PAGOS " & Mes & " " & Dia
    parte2.display
    Application.SendKeys "^v", True
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")
    DoEvents
    parte2.send
    Set parte1 = Nothing
    Set parte2 = Nothing
    '
    correo = Range("d24").Value
    Range("c22:f40").Copy
    Set parte1 = CreateObject("outlook.application")
    Set parte2 = parte1.createitem(olmailitem)
    parte2.to = correo
    parte2.Subject = "ROL DE PAGOS " & Mes & " " & Dia
    parte2.display
    Application.SendKeys "^v", True
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")
    DoEvents
    parte2.send
    Set parte1 = Nothing
    Set parte2 = Nothing
End Sub

Saludos.Dante Amor

Estimado Dante la macro funciona, pero en la segunda instrucción se envía el correo pero no con el rango copiado, es decir llega vacío el correo.

Favor su ayuda

Te anexo la macro actualizada

Sub correo_Macro2()
    Dia = Range("i2").Value
    Mes = Range("j2").Value
    If Range("d3") <> "" And Range("d24") <> "" Then
        correo = Range("d3").Value
        Range("c7:f21").Copy
        Set parte1 = CreateObject("outlook.application")
        Set parte2 = parte1.createitem(olmailitem)
        parte2.to = correo
        parte2.Subject = "ROL DE PAGOS " & Mes & " " & Dia
        parte2.Body = ""
        Parte2. Display
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Application.SendKeys "^v", True
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Parte2. Send
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Set parte1 = Nothing
        Set parte2 = Nothing
        '
        DoEvents
        correo = Range("d24").Value
        Set parte1 = CreateObject("outlook.application")
        Set parte2 = parte1.createitem(olmailitem)
        parte2.to = correo
        parte2.Subject = "ROL DE PAGOS parte2" & Mes & " " & Dia
        parte2.Body = ""
        Parte2. Display
        Range("c22:f40"). Copy
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Application.SendKeys "^v", True
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Parte2. Send
        Application. Wait Now + TimeValue("00:00:03")
        DoEvents
        Set parte1 = Nothing
        Set parte2 = Nothing
    Else
        MsgBox "Falta correo en la celda D3 o D24"
    End If
End Sub

Estimado Experto he actualizado la macro en base a lo aconsejado y he tenido los siguientes inconvenientes:

1.- La parte 2 ("c22:F40") llega por email al correo 1 ("d3"); debería llegar al correo 2 ("d24")

2.- La parte 1 ("c7:f21") llega por email al correo 2 ("d24") debería llegar al correo 1; y adicional este llega vacío.

Favor su ayuda


                    

A mí me funciona muy bien!

Estoy incrementando el tiempo de espera, para que el correo se cargue, se pueda pegar la información y después se envíe. Puede ser que tu correo tiene problemas al abrirse, entonces cuando llega la imagen del primer correo todavía no se abre el correo, entonces llega la imagen del segundo correo y es cuando el primer correo apenas abrió y por eso recibe la imagen del segundo correo.

Prueba con esta macro y me comentas.

Sub correo_Macro2()
    Dia = Range("i2").Value
    Mes = Range("j2").Value
    If Range("d3") <> "" And Range("d24") <> "" Then
        correo = Range("d3").Value
        Range("c7:f21").Copy
        Set parte1 = CreateObject("outlook.application")
        Set parte2 = parte1.createitem(olmailitem)
        parte2.to = correo
        parte2.Subject = "ROL DE PAGOS " & Mes & " " & Dia
        parte2.Body = ""
        Parte2. Display
        DoEvents
        Application. Wait Now + TimeValue("00:00:05")
        DoEvents
        Application.SendKeys "^v", True
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Parte2. Send
        Application. Wait Now + TimeValue("00:00:03")
        DoEvents
        Set parte1 = Nothing
        Set parte2 = Nothing
        '
        DoEvents
        correo2 = Range("d24").Value
        Set parte1 = CreateObject("outlook.application")
        Set parte2 = parte1.createitem(olmailitem)
        parte2.to = correo2
        parte2.Subject = "ROL DE PAGOS parte2" & Mes & " " & Dia
        parte2.Body = ""
        Parte2. Display
        Range("c22:f40"). Copy
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Application.SendKeys "^v", True
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Parte2. Send
        Application. Wait Now + TimeValue("00:00:03")
        DoEvents
        Set parte1 = Nothing
        Set parte2 = Nothing
    Else
        MsgBox "Falta correo en la celda D3 o D24"
    End If
End Sub

Estimado, ya chequee haber si el problema es de outlook pero todo esta bien

Me sigue generando problema el primero se va .. pero el segundo se envía sin información

Sigue aumentando el tiempo para ver con cuál te funciona bien.

Cambia el número en estas líneas, significa que debe esperar 5 segundos, aumenta todas las líneas a 7 y prueba

Application. Wait Now + TimeValue("00:00:05")

Como ya te comenté a mí me funciona muy bien en excel 2007, incluso con menos tiempo.

La otra que se me ocurre es que pongas 2 botones, en un botón pones el código para enviar el correo1 y en el otro botón pones el código para enviar el correo2:

Correo1:

Sub correo1()
    Dia = Range("i2").Value
    Mes = Range("j2").Value
    If Range("d3") <> "" Then
        correo = Range("d3").Value
        Range("c7:f21").Copy
        Set parte1 = CreateObject("outlook.application")
        Set parte2 = parte1.createitem(olmailitem)
        parte2.to = correo
        parte2.Subject = "ROL DE PAGOS " & Mes & " " & Dia
        parte2.Body = ""
        Parte2. Display
        DoEvents
        Application. Wait Now + TimeValue("00:00:05")
        DoEvents
        Application.SendKeys "^v", True
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Parte2. Send
        Application. Wait Now + TimeValue("00:00:03")
        DoEvents
        Set parte1 = Nothing
        Set parte2 = Nothing
    Else
        MsgBox "Falta correo en la celda D3"
    End If
End Sub

Correo2

Sub correo2()
    Dia = Range("i2").Value
    Mes = Range("j2").Value
    If Range("d3") <> "" And Range("d24") <> "" Then
        DoEvents
        correo2 = Range("d24").Value
        Set parte1 = CreateObject("outlook.application")
        Set parte2 = parte1.createitem(olmailitem)
        parte2.to = correo2
        parte2.Subject = "ROL DE PAGOS parte2" & Mes & " " & Dia
        parte2.Body = ""
        Parte2. Display
        Range("c22:f40"). Copy
        DoEvents
        Application. Wait Now + TimeValue("00:00:05")
        DoEvents
        Application.SendKeys "^v", True
        DoEvents
        Application. Wait Now + TimeValue("00:00:01")
        DoEvents
        Parte2. Send
        Application. Wait Now + TimeValue("00:00:03")
        DoEvents
        Set parte1 = Nothing
        Set parte2 = Nothing
    Else
        MsgBox "Falta correo en la celda D24"
    End If
End Sub

¡Gracias! Estimado no me ha funcionado ..quizá sea la version de excel

Lo que se me ha ocurrido es utilizar una sola plantilla para todo el personal, así a través de validación de datos voy buscando el empleado y se van actualizando los valores.

Posterior a esto he creado un botón para que ejecutar una sola macro empleado por empleado; al inicio la macro se ejecuta correctamente pero al momento de ingresar otro nombre de empleado y ejecutar la macro esta me copia los datos del anterior empleado.

me puede ayudar . gracias

Adjunto la macro definitiva y el ejemplo

Respuesta
-1

Y como eliges el rango

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas