Enviar Rango de Celdas a diferentes correos electrónicos
Quería solicitar su ayuda, tengo un modulo en excel que me convierte un rango de celdas a pdf y luego lo envía por correo electrónico,
Sub Folio()
Dim NombreArchivo As String
NombreArchivo = Range("C6").Value
ActiveSheet.Range("A1:E
38").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Compartida\COLILLAS DE PAGO" & NombreArchivo & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
strReportName = "C:\Compartida\COLILLAS DE PAGO\NOMINA SO 032017.xlsm"
For Each cell In Range("H1:H16")
Dim objOutlook As Object
Dim objMail As Object
Dim objOutlookAttach As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(olMailItem)
Set objOutlookAttach = objOutlook.CreateItem(olAttachMents)
With objMail
'A quien va dirigido el correo
.To = "[email protected];[email protected]"
'Se especifica el asunto
.Subject = "COLILLA DE PAGO"
'Se escriben el o los archivos a adjuntar en el mail
.Attachments.Add "C:\Compartida\COLILLAS DE PAGO" & NombreArchivo & ".pdf"
'Se manda el mensaje
.Send
End With
'Se cierran todos los objetos utilizados
Set objMail = Nothing
end sub
Lo que quiero hacer es que en una hoja donde tengo unas 200 colillas de pago hacia abajo ocupan 6 columnas y 38 filas, necesito que se envíen a diferentes correos electrónicos automáticamente los diferentes rangos a un correo electrónico por ejemplo A1 : F38 se envía al Primer correo electrónico de un listado, A39 : F76 al segundo correo del listado y así sucesivamente hasta lllegar al final del listado de correos ya que como lo tengo en este momento me tocaria escribir 200 veces el destinatario y el rango de celdas que tengo que enviar, no se si me he hecho explicar correctamente y agradezco cualquier ayuda de antemano.
1 Respuesta
Te anexo la macro actualizada
Sub Folio()
'Act.Por.Dante Amor
Dim NombreArchivo As String, ruta As String, j As Integer, i As Integer
Dim dam As Object
'
ruta = "C:\Compartida\COLILLAS DE PAGO"
'
j = 1
For i = 2 To Range("H" & Rows.Count).End(xlUp).Row
NombreArchivo = Range("C" & j + 5).Value
ActiveSheet.Range("A" & j & ":F" & j + 37).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & NombreArchivo & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
'
Set dam = CreateObject("Outlook.Application").CreateItem(olMailItem)
dam.To = "[email protected];[email protected]"
dam.Subject = "COLILLA DE PAGO"
dam.Attachments.Add ruta & NombreArchivo & ".pdf"
dam.Send
Set dam = Nothing
j = j + 38
Next
MsgBox "Correos enviados"
End Sub.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
Buenos días,
Muchas gracias por la ayuda pero estoy viendo que los correos aun se envían a los que yo ponga manualmente en
dam.To = "[email protected];[email protected]"
y no a los que que tengo en H
Buenos días lo solucione cambiando el el For i por un For Each cell in range(""), y cambiando el set dam por un Set MItem con un With, Muchas gracias por la ayuda.
Sub Folio()
Dim NombreArchivo As String, ruta As String, j As Integer, i As Integer
Dim dam As Object
'
ruta = "C:\Compartida\COLILLAS DE PAGO"
'
j = 1
For Each cell In Range("H1:H2")
Correo = cell.Value
NombreArchivo = Range("C" & j + 5).Value
ActiveSheet.Range("A" & j & ":F" & j + 37).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & NombreArchivo & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
'
Set MItem = CreateObject("Outlook.Application").CreateItem(olMailItem)
With MItem
.To = Correo
.Subject = "COLILLA DE PAGO"
.Attachments.Add ruta & NombreArchivo & ".pdf"
.Send
End With
j = j + 38
Next
MsgBox "Correos enviados"
End Sub
Me faltó esa parte.
Te anexo la macro actualizada
Sub Folio()
'Act.Por.Dante Amor
Dim NombreArchivo As String, ruta As String, j As Integer, i As Integer
Dim dam As Object
'
ruta = "C:\Compartida\COLILLAS DE PAGO"
'
j = 1
For i = 2 To Range("H" & Rows.Count).End(xlUp).Row
NombreArchivo = Range("C" & j + 5).Value
ActiveSheet.Range("A" & j & ":F" & j + 37).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & NombreArchivo & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
'
Set dam = CreateObject("Outlook.Application").CreateItem(olMailItem)
dam.To = cells(i, "H").value
dam.Subject = "COLILLA DE PAGO"
dam.Attachments.Add ruta & NombreArchivo & ".pdf"
dam.Send
Set dam = Nothing
j = j + 38
Next
MsgBox "Correos enviados"
End Subsal u dos
