Enviar Rango Excel por correo desde listado v3
Tengo esta macro para enviar desde excel por correo un determinado rango que filtra por proveedor, identifica el correo y manda la selección enviada.
Es esta:
Sub Enviar_Correos_a_Proveedores()
'Por Dante Amor
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set h1 = Sheets("Resumen")
Set h2 = Sheets("proveedores") 'hoja con los id de proveedores
'
h1.Select
For i = 2 To h2.Range("A" & Rows.Count).End(xlUp).Row
h1.Range("E3").Value = h2.Cells(i, "A")
h1.ListObjects("Tabla1").Range.AutoFilter Field:=15, Criteria1:=h1.Range("E3").Value
u = h1.Range("O" & Rows.Count).End(xlUp).Row
h1.Range("A6:O" & u).Select
ActiveSheet.Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Item.to = h1.Range("E5").Value
.Item.cc = "[email protected]" 'con copia a...
.Item.bcc = "[email protected]" 'con copia oculta a...
.Item.Subject = h1.Range("A6").Value
.Introduction = ""
.Item.send
End With
Next
MsgBox "Correos enviados"
End SubMe gustaría mejorar la macro para que hiciera lo siguiente:
1 - Pasa por todos los proveedores de la pestaña proveedores, y envía algunos que no coinciden con los números de proveedor de la columna O. Seria posible que hiciera un BUSCARV solo con los de la "Table1" de la columna ID proveedor, ¿seria más rápido? ¿Ya qué así devolvería solo el correo de los que encuentre?
2 - y la más importante, al filtrar y enviar a un proveedor la información y enviarlo como una tabla, desde el email recibido puedes copiar la info ponerla en un excel y ver todas las filas ocultas, ¿esto se puede cambiar? Ya que sino estoy dando información a otros proveedores de pedidos de otros cosa que no quiero.
Te pongo una imagen de la pestaña proveedores:
1 respuesta
Andaba ocupado, por eso no había podido responder.
Prueba con la siguiente macro
Crea 2 hojas y les pones por nombre "Temp1" y "Temp2"
Sub Enviar_Correos_a_Proveedores()
'Por Dante Amor
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set h1 = Sheets("Resumen")
Set h2 = Sheets("proveedores") 'hoja con los id de proveedores
Set h3 = Sheets("Temp1")
Set h4 = Sheets("Temp2")
'
h3.Cells.Clear
'
h1.Select
On Error Resume Next
h1.ListObjects("Tabla1").Range.AutoFilter
On Error GoTo 0
'
u = h1.Range("O" & Rows.Count).End(xlUp).Row
h1.Range("O12:O" & u).Copy
h3.Range("A1").PasteSpecial xlValues
u3 = h3.Range("A" & Rows.Count).End(xlUp).Row
h3.Range("A1:A" & u).RemoveDuplicates Columns:=1, Header:=xlYes
'
For i = 2 To h3.Range("A" & Rows.Count).End(xlUp).Row
h4.Cells.ClearContents
h1.Range("E3").Value = h3.Cells(i, "A")
h1.ListObjects("Tabla1").Range.AutoFilter Field:=15, Criteria1:=h1.Range("E3").Value
u = h1.Range("O" & Rows.Count).End(xlUp).Row
h1.Range("A1:O" & u).Copy h4.Range("A1")
h4.Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Item.To = h1.Range("E5").Value
.Item.cc = "[email protected]" 'con copia a...
.Item.bcc = "[email protected]" 'con copia oculta a...
.Item.Subject = h1.Range("A6").Value
.Introduction = ""
.Item.send
End With
Next
MsgBox "Correos enviados"
End Sub'.[Sal u dos. Dante Amor. No olvides valorar la respuesta.
Avísame cualquier duda.
