ENVIAR HOJA por correo respetando filtros y con ocultar NO eliminar filas
Tengo esta macro que filtra y guarda copia
Sub PAN_PEDIR()
Application.ScreenUpdating = False
'---MACRO: PASTEL_PEDIR
'---NACRO: COCINA_PEDIRexiste = False
For Each c In Range("G6:AE360")
If Not IsNumeric(c) Then
existe = True
Exit For
End If
Next
If existe Then
MsgBox "No se puede continuar porque hay letras", vbOKOnly, "PROGRAMA DE PEDIDOS"
Else
'continuar
End If
Application.ScreenUpdating = FalseIf Range("E1") > 0 Then
MsgBox "NO PODEMOS CONTINUAR, PORFAVOR: VERIFIQUE SU PEDIDO", vbExclamation, "LO SENTIMOS"
Exit Sub
End If
Dim s As Long
s = Application.WorksheetFunction.Sum(Range("G6:AE360"))If s = Empty Then
MsgBox "NO HAY CANTIDADES PARA REALIZAR PEDIDO", vbCritical, "ERROR"Else
Dim PEDIDO As Variant
' Application.Speech.Speak "¿EL CLIENTE SOLICITARÁ FACTURA?"
PEDIDO = MsgBox("¿REALIZAR PEDIDO?", vbYesNo + vbQuestion, "AVISO")
If PEDIDO = vbYes Then'FILTRA LOS PRODUCTOS CON MAYOR A CERO
ActiveSheet.Unprotect
ActiveSheet.Range("$F$5:$F$360").AutoFilter Field:=1, Criteria1:=">0", _
Operator:=xlAnd
'IMPRIMIMOS REPORTE APTS
Range("B2:AE360").Select
'Sheets("PANADERIA").Columns("G:AE").EntireColumn.AutoFit
ActiveSheet.PageSetup.PrintArea = "$B$2:$AE$360"
'QUITAMOS RELLENO VERDE
ActiveSheet.Unprotect
Cells.Select
Range("B1").Activate
With Selection.Interior
ActiveSheet.Unprotect
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'IMPRIMIMOS
OCULTAEXPPAN
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
Sheets("PANADERIA").Select
MUESTRAPAN
Application.ScreenUpdating = False
Call guardaCopiaPANADERIA
'
Sheets("IMPRIME PAN").Activate ' CAMABIAMOS---- HOJA -----DE----- IMPRESION---- SEGUN ---SEA---- LA HOJA
ActiveSheet.Unprotect
ActiveSheet.Range("$C$5:$C$360").AutoFilter Field:=1, Criteria1:=">0", _
Operator:=xlAnd
'QUITAMOS RELLENO VERDE
ActiveSheet.Unprotect
Cells.Select
Range("B1").Activate
With Selection.Interior
ActiveSheet.Unprotect
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'IMPRIMIMOS POR SEGUNDA VEZ
Range("B2:F366").Select
ActiveSheet.PageSetup.PrintArea = "$B$2:$f$366"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
IgnorePrintAreas:=False
'REGRESAMOS AL AREA CORRESPONDIENTE
Sheets("PANADERIA").Select 'CAMBIAMOS ----ALA ----HOJA ----QUE TRABAJAMOS
'QUITAMOS FILTRO DEL AREA Y BORRAMOS CONTENIDO
Application.ScreenUpdating = False
ActiveSheet.Unprotect
ActiveSheet.Range("$F$5:$F$360").AutoFilter Field:=1
Range("G6:AE360").Select
ActiveSheet. Unprotect
Selection.ClearContents
Range("G6").Select
'QUITAMOS FILTRO DE IMPRESIÓN
Sheets("IMPRIME PAN").Activate ' CAMABIAMOS---- HOJA -----DE----- IMPRESION---- SEGUN ---SEA---- LA HOJA
ActiveSheet.Range("$C$5:$C$360").AutoFilter Field:=1
'REGRESAMOS DE NUEVO AL AREA
Sheets("PANADERIA").Select 'CAMBIAMOS ----ALA ----HOJA ----QUE TRABAJAMOS
ActiveSheet.Unprotect
[E2] = "PN" & Format(Val(Right([E2], 3)) + 1, "00000") 'CAMBIAR--- FOLIS-- CO:COCINA----PS:PASTEL
MsgBox "PEDIDO REALIZADO", vbOKOnly, "EN HORA BUENA"
If PEDIDO = vbNo Then
MsgBox "PEDIDO CANCELADO", vbInformation, "PANADERIA" 'CAMBIAR ----NOMBRE DE -----MSGBOX---- POR---- AREA
End If
End If
End If
End Sub
Entonces en este código quiero agregar otro que sirve para enviar por correo
Sub CorreoPAN()
'por.Dante Amor
'Enviar una hoja por correo
ActiveSheet.Unprotect
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'
Set L1 = ThisWorkbook
Set h1 = Sheets("PANADERIA")
CEL = h1.[B364]
CEL4 = h1.[E2]
CEL5 = h1.[B2]
ruta = L1.Path & "\"
Set l2 = Workbooks.Add
Set h2 = l2.Sheets(1)
h1.Range("B2:AE360").Copy
h2.[B2].PasteSpecial Paste:=xlValues
h2.[B2].PasteSpecial Paste:=xlPasteFormats
l2.SaveAs Filename:=ruta & h1.Name & ".xlsx", FileFormat:=xlOpenXMLWorkbook
l2.Close
'
Set dam = CreateObject("outlook.application").createitem(0) '
dam.To = "[email protected]"
dam.Subject = "Pedido a Producción Area: " & CEL5 & " Folio : " & CEL4 '"Asunto"
dam.Body = "Pedido Realizado el dia: " & CEL & "CONFIRMA DE RECIBIDO" '"Cuerpo del mensaje"
dam.Attachments.Add ruta & h1.Name & ".xlsx"
dam.Send
ActiveSheet.Protect
MsgBox "Correo enviado y guardado", vbInformation, "PEDIDO DE PANADERIA"
End Sub
Entonces quisiera que cuando yo ejecute el primer código
FILTRE
Guarde una copia
Entonces me ENVÍE por correo la hoja pero que sea con filtros
Para luego me imprima respetando también filtros
Todo FUNCIONA BIEN
Solo falta que me envíe por correo respetando filtros
ESPERO SU AYuda
EN OTRA PREGUNTA ANEXO LOS DEMÁS CÓDIGOS que integran el primer código para así poder anexar el código que envía por correo
Valoro las 2 preguntas