Como mandar correos masivos desde Excel. (Adjuntando archivos).
Todos los meses debo enviar un montón de correos informando a cada unidad los descuentos realizados por distintas actividades. Son muchos correos que debo generar a partir de una base en Excel, desde la cual genero la información y después debo mandarla por correo al destinatario.
Pido ayuda para generar esta información a través de macros, ya sea la generación de cada archivo como el envío del correo de éste.
Se necesita que se vayan generando, desde un archivo base, archivos según parámetros indicados. Se genera el archivo y se manda por correo, se guarda una copia del correo enviado en una carpeta que está en otra carpeta.
El nombre que debiera llevar el archivo es celda C2 + mes y año de generación (Ej: Administracion 201606.xls) y la subcarpeta en que deberá quedar la información (E2, la cual se encuentra en la carpeta D2).
A veces es un concepto el que va en el archivo, otras es más de una vez. Según el nombre del archivo deben ir los conceptos.
Se adjunta archivos, Descuentos 201606, desde donde se generan los otros archivos y Administracion 201606 como ejemplo de lo que se necesita.
1 Respuesta
Te anexo la macro completa
Sub GenerarCorreos()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("BASE")
Set h2 = l1.Sheets("PARAMETROS")
Set h3 = l1.Sheets("Temp")
Set h4 = l1.Sheets("Formato")
'
h3.Cells.Clear
h4.Cells.Clear
If h1.AutoFilterMode Then h1.AutoFilterMode = False
If h2.AutoFilterMode Then h2.AutoFilterMode = False
'
ruta = ThisWorkbook.Path & "\"
año = Year(h1.[I1])
mes = Format(Month(h1.[I1]), "00")
'
h2.Columns("C:C").Copy h3.[A1]
u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
h3.Range("A1:A" & u3).RemoveDuplicates Columns:=1, Header:=xlYes
For i = 2 To h3.Range("A" & Rows.Count).End(xlUp).Row
j = 2
Set r = h2.Columns("C")
Set b = r.Find(h3.Cells(i, "A"), lookat:=xlWhole)
If Not b Is Nothing Then
celdai = b.Address
nombre = h2.Cells(b.Row, "C").Value
carpet = h2.Cells(b.Row, "D").Value & "\"
subcar = h2.Cells(b.Row, "E").Value & "\"
paraev = h2.Cells(b.Row, "F").Value
concop = h2.Cells(b.Row, "G").Value
asunto = h2.Cells(b.Row, "H").Value
cuerpo = h2.Cells(b.Row, "I").Value
Do
'detalle
h3.Cells(i, j).Value = b.Offset(0, -1).Value
j = j + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celdai
arreglo = Array(h3.Range(h3.Cells(i, 2), h3.Cells(i, j - 1)))
End If
'
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
h1.Range("A1:H" & u1).AutoFilter Field:=5, Criteria1:=Array(arreglo), _
Operator:=xlFilterValues
'
u1 = h1.Range("C" & Rows.Count).End(xlUp).Row
h1.Range("A1:H" & u1).Copy h4.[A1]
h4.Copy
Set l2 = ActiveWorkbook
l2.Sheets(1).Name = año & mes
rutades = ruta & carpet & subcar
archivo = nombre & " " & año & mes
l2.SaveAs Filename:=rutades & archivo & ".xlsx" ', FileFormat:=xlOpenXMLWorkbook
'l2.SaveAs Filename:=rutades & archivo & ".xls", FileFormat:=xlNormal
l2.Close
'
'ENVIAR CORREO
Dim objOL As New Outlook.Application
Dim objMail As MailItem
Set objOL = New Outlook.Application
Set dam = objOL.CreateItem(olMailItem)
dam.To = paraev
dam.CC = concop
dam.Subject = asunto
dam.Body = cuerpo
dam.Attachments.Add rutades & archivo & ".xlsx"
dam.Send 'El correo se envía en automático
'dam.display 'El correo se muestra
Set dam = Nothing
Next
MsgBox "Fin"
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
