Envió masivo de correos mediante outlook excel-vba

Tengo un detalle con el envió de correos a varios destinatarios según unas condiciones. En una tabla contenida en una hoja ("MANTENIMIENTO PREVENTIVO") de 10 columnas, en la misma llevo la frecuencia de mantenimiento a varios equipos. El objetivo de la macro es enviar un correo al gerente, al jefe de mantenimiento y copia a los supervisores del área justo cuando quedan menos de 5 días para cumplirse la fecha correspondiente, todo esto sucede al abrir el archivo de excel. Les muestro la tabla:

Ahora bien el detalle es que me envía un correo por cada actividad que hay para cada equipo Ej. Si un equipo ya le quedan menos de 5 días y tiene mas de 1 una actividad a realizar me envía un correo por cada actividad saturando así la bandeja de entrada de los destinatarios, YO SOLO BUSCO QUE ENVÍE UNA COPIA A LOS DESTINATARIOS (SUPERVISORES) CORRESPONDIENTES POR CADA ÁREA, cuando se acerque su actividad respectiva. Les muestro el código: Solo necesito que en el ciclo For se detenga cuando consiga el primer dato con las condiciones del if envíe un solo correo no por cada actividad y luego busque si hay otra maquina con las mismas condiciones para enviar el correspondiente correo.

1 Respuesta

Respuesta
1

[Hola 

Envíame tu archivo a [email protected]  o sube a la nube tu archivo

Este es el código:

Sub enviarcorreo()
Dim a, b, pagina1 As Worksheet
Dim i, uf, n, dato As Long
Dim OutApp As Object
Dim Correo As Object
Set pagina1 = ActiveWorkbook.Worksheets("Correos")
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
'Comprobar si Outlook esta abierto y en caso de no estarlo abrirlo
On Error Resume Next
Set OutApp = GetObject("", "Outlook.Application")
Err.Clear
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
OutApp.Visible = True
Set a = Sheets("MANTENIMIENTO PREVENTIVO")
a.Select
uf = a.Range("A" & Rows.Count).End(xlUp).Row
n = 1
    For i = 6 To uf
        n = n + 1
        If a.Cells(i, "A").Value = "Extrusion" And a.Cells(i, "I") = 3 Then
             Set Correo = OutApp.CreateItem(0)
             'Crear el correo y mostrarlo
             With Correo
                 .Display
                 .To = pagina1.Range("B5").Value & ";" & pagina1.Range("C5").Value
                 .CC = pagina1.Range("B6").Value
                 .Subject = "Grupo Extrusoras. " & pagina1.Range("B11").Value
                 .HTMLBody = "Saludos." & "<br><br>" & pagina1.Range("B12").Value & _
                             "<br><br><br><br>" & "********NOTA: Este correo es generado de forma automatica***********" & _
                             "<br><br><br>" & .HTMLBody
            End With
         End If
        If a.Cells(i, "A").Value = "Laminadoras" And a.Cells(i, "I") = 3 Then
            Set Correo = OutApp.CreateItem(0)
            'Crear el correo y mostrarlo
            With Correo
                .Display
                .To = pagina1.Range("B5").Value & ";" & pagina1.Range("C5").Value
                .CC = pagina1.Range("B8").Value
                .Subject = "Grupo Laminadoras" & pagina1.Range("B11").Value
                .HTMLBody = "Saludos." & "<br><br>" & pagina1.Range("B12").Value & _
                            "<br><br><br><br>" & "********NOTA: Este correo es generado de forma automatica***********" & _
                            "<br><br><br>" & .HTMLBody
            End With
         End If
    Next i
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

[Hola 

prueba así 

Sub enviarcorreo()
Dim a, b, pagina1 As Worksheet
Dim i, uf, n, dato As Long
Dim OutApp As Object
Dim Correo As Object
Set pagina1 = ActiveWorkbook.Worksheets("Correos")
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
'Comprobar si Outlook esta abierto y en caso de no estarlo abrirlo
On Error Resume Next
Set OutApp = GetObject("", "Outlook.Application")
Err.Clear
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
OutApp.Visible = True
Set a = Sheets("MANTENIMIENTO PREVENTIVO")
a.Select
uf = a.Range("A" & Rows.Count).End(xlUp).Row
n1 = 0
n2 = 0
    For i = 6 To uf
        If a.Cells(i, "A").Value = "Extrusion" And a.Cells(i, "I") = 3 Then
        If n1 = 1 Then Exit For
             Set Correo = OutApp.CreateItem(0)
             'Crear el correo y mostrarlo
             With Correo
                 .Display
                 .To = pagina1.Range("B5").Value & ";" & pagina1.Range("C5").Value
                 .CC = pagina1.Range("B6").Value
                 .Subject = "Grupo Extrusoras. " & pagina1.Range("B11").Value
                 .HTMLBody = "Saludos." & "<br><br>" & pagina1.Range("B12").Value & _
                             "<br><br><br><br>" & "********NOTA: Este correo es generado de forma automatica***********" & _
                             "<br><br><br>" & .HTMLBody
            End With
            n1 = n1 + 1
         End If
    Next i
    For j = 6 To uf
        If n2 = 1 Then Exit For
        '
        If a.Cells(j, "A").Value = "Laminadoras" And a.Cells(j, "I") = 3 Then
            Set Correo = OutApp.CreateItem(0)
            'Crear el correo y mostrarlo
            With Correo
                .Display
                .To = pagina1.Range("B5").Value & ";" & pagina1.Range("C5").Value
                .CC = pagina1.Range("B8").Value
                .Subject = "Grupo Laminadoras" & pagina1.Range("B11").Value
                .HTMLBody = "Saludos." & "<br><br>" & pagina1.Range("B12").Value & _
                            "<br><br><br><br>" & "********NOTA: Este correo es generado de forma automatica***********" & _
                            "<br><br><br>" & .HTMLBody
            End With
            n2 = n2 + 1
         End If
    Next j
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

Hola Adriel.

¡Gracias! 

Funciono perfectamente, ya aprendí algo nuevo como detener un ciclo for mediante una condición

Dios te bendiga... 

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas