Enviar Rango Excel por correo desde listado v2

Para Dante.

Siguiendo con el otro hilo, tengo la macro que me mejoraste 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]yse.com"  '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

Me 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

1 Respuesta

4.664.875 pts. Sancho, si los perros ladran ...

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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas