Guardar múltiples PDFs al encontrar un Subtotal

Estimados necesito de su ayuda con lo siguiente: tengo una macro que guarda un PDF cada vez que encuentra un salto de Página (ActiveSheet. HPageBreaks). Le agregué Subtotales mediante la función, al archivo con el cual estoy trabajando y hay clientes cuyo reporte solo es de 1 página y la macro guarda un PDF con los datos de ese cliente, pero otros tienen reportes que van desde 2 hasta por cantidad de páginas y la macro me guarda tantos PDF como páginas tiene ese cliente. La idea es modificar la macro para que pueda guardar un solo PDF con la cantidad de hojas que tenga al encontrar un Subtotal (Ubicados en la columna "B") y no al encontrar un salto de página. Acá el código que tengo actualmente:

Sub GuardarMultiplesPDFBD()
Application.ScreenUpdating = False
Dim number_of_files As Integer
ActiveSheet.HPageBreaks.Add Before:=ActiveCell '
number_of_files = ActiveSheet.HPageBreaks.Count
carpeta = Cells(3, 16)
fecha = Cells(7, 4)
filename0 = carpeta
For x = 1 To number_of_files
    row_pagebreak = ActiveSheet.HPageBreaks(x).Location.Row
    filename1 = ActiveSheet.Cells(row_pagebreak - 1, 2).Value & " " & fecha
    full_filename = filename0 & filename1
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            full_filename, Quality:= _
            x1QualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            From:=x, To:=x, OpenAfterPublish:=False
Next
End Sub

1 respuesta

Respuesta
1

H o l a:

Te anexo la macro.

Deberás cambiar en la macro lo siguiente:

 Fila = 1 'número de fila donde empieza la impresión
 col = "D" 'columna final de impresión

También tienes que poner cuántas filas hay después del subtotal para el siguiente nombre de archivo en esta línea:

fila = b.Row + 1


Sub GuardarMultiplesPdf()
'Por.Dante Amor
    fila = 1                'número de fila donde empieza la impresión
    col = "D"               'columna final de impresión
    carpeta = Cells(3, 16)
    fecha = Cells(7, 4)
    '
    Set h = ActiveSheet
    Set r = h.Columns("B")
    Set b = r.Find("SUBTOTAL", LookAt:=xlPart, LookIn:=xlFormulas)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            filename1 = h.Cells(fila, "B") & " " & fecha
            h.PageSetup.PrintArea = "A" & fila & ":" & col & b.Row
            h.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=carpeta & filename1 & ".pdf", Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            fila = b.Row + 1
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If
    MsgBox "Fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Buenas tardes.

Dante está excelente, hace justo lo que se quiere. Pero sabes que cuando llega a cierto punto se para y arroja error. Justo cuando llega casi a los ultimos reportes, específicamente cuando llega a un proveedor de apellido CONCHA. Como hago para anexarte el archivo con el cual estoy trabajando a ver si me ayudas a descubrir qué está pasando?

¿Qué error te pone?

¿En qué línea de la macro se detiene?

Tienes fórmulas en las celdas, alguna de las fórmulas tiene error del tipo "#", revisa que las celdas no tengan error, corrige los errores.

¿La fecha tiene diagonales? Entonces cambia esta línea

fecha = Cells(7, 4)

Por esta:

Fecha = format(Cells(7, 4), "dd-mm-yyyy")

El problema está en tus datos, no en la macro.

R ecuerda valorar la respuesta. 


Si todavía tienes problemas, entonces envíame toda la información:

¿Qué error te pone?

¿En qué línea de la macro se detiene?

Tienes fórmulas en las celdas, alguna de las fórmulas tiene error del tipo "#", revisa que las celdas no tengan error, corrige los errores.

¿La fecha tiene diagonales?


Mi correo [email protected]

En el asunto del correo escribe tu nombre de usuario “jezreelv” y el título de esta pregunta.

La celda de la fecha ya tenía el formato con guiones "-", porque ya sabía que al tener diagonales asume que es una dirección a una carpeta o archivo. La macro funciona, de hecho en esta ocasión son 391 reportes que debe generar en PDF, y guarda 365 y cuando va a guardar el siguiente (366) se detiene y arroja este error: "Se ha producido el error '-2147024773 (8007007b)' en tiempo de ejecución: El documento no se guardó". Y marca el error en estas  lineas del guardado tipo PDF: 

h.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=carpeta & filename1 & ".pdf", Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

Aunque todos los reportes tienen como parte de su nombre una fecha estática (31-05-2016) tendrá algo que ver con los 365 días del año? porque me causa curiosidad que se detiene justo cuando va a guardar el reporte numero 366.

Te voy a enviar el archivo al correo. Gracias de antemano. Al concluir el tema se valora la respuesta o se debe valorar cada una?

Listo ya lo envié.

En las filas 20367 el nombre tiene un carácter extraño, por eso no puede guardar el archivo.

Simplemente borra ese caracter y vuelve a ejecutar la macro.

'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

 

Prueba con la siguiente macro para que te genere todos los archivos

Sub GuardarMultiplesPdf()
'Por.Dante Amor
    on error resume next
    fila = 1                'número de fila donde empieza la impresión
    col = "D"               'columna final de impresión
    carpeta = Cells(3, 16)
    fecha = Cells(7, 4)
    '
    Set h = ActiveSheet
    Set r = h.Columns("B")
    Set b = r.Find("SUBTOTAL", LookAt:=xlPart, LookIn:=xlFormulas)
    If Not b Is Nothing Then
        celda = b.Address
        Do
            filename1 = h.Cells(fila, "B") & " " & fecha
            h.PageSetup.PrintArea = "A" & fila & ":" & col & b.Row
            h.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=carpeta & filename1 & ".pdf", Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
            fila = b.Row + 1
            Set b = r.FindNext(b)
        Loop While Not b Is Nothing And b.Address <> celda
    End If
    MsgBox "Fin"
End Sub
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas