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
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...
