Exportar a un sólo PDF que depende de una ficha de empleado

Tengo un Excel donde hay una pestaña en la que según despliegas a una persona, se rellena su ficha con horarios, días libres,...

Tengo una macro hecha en la que automáticamente va cambiando el nombre del empleado e imprimiendo uno a uno. Ahora, lo que necesitaría es que, en vez de imprimir, exportara cada ficha de empleado a un archivo PDF, teniendo en cuenta que cada persona debería ir en una hoja, la orientación debería ser horizontal, también debe ser que copie el formato, los valores (ya que son fórmulas) y además hay celdas combinadas. En definitiva, lo que busco es que la ficha que se imprime aparezca igual en un PDF, con una hoja para cada ficha de las personas. Estoy buscando donde poder depositar el fichero, pero no lo encuentro.

1 Respuesta

Respuesta
1

Envíame el archivo a mi correo

Mi correo [email protected]

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

Hola, buenos días. Ya te he enviado el correo. Un saludo, gracias.

Te anexo la macro actualizada

Sub imprime()
'Por.Dante Amor
    Pregunta = MsgBox("Se van a imprimir TODOS los empleados. ¿ESTÁS SEGURO?", _
        vbQuestion + vbYesNo, "¡¡ OJO !!. Importante")
    If Pregunta = 7 Then End
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set h1 = Sheets("Planificación anual")
    Set h2 = Sheets("Calendario")
    '
    Set h3 = Sheets.Add
    '
    With h3.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.669291338582677)
        .RightMargin = Application.InchesToPoints(0.47244094488189)
        .TopMargin = Application.InchesToPoints(0.275590551181102)
        .BottomMargin = Application.InchesToPoints(0.354330708661417)
        .HeaderMargin = Application.InchesToPoints(0.15748031496063)
        .FooterMargin = Application.InchesToPoints(0.15748031496063)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    '
    For n = 7 To h2.Range("BG3")
        h2.Range("E6") = h1.Range("F" & n)
        h2.PrintOut Copies:=1, Collate:=True
        u = h3.UsedRange.Rows(h3.UsedRange.Rows.Count).Row + 1
        If u = 2 Then u = 1
        Set rango = Range("A1:AD40")
        h2.Range(rango.Address).Copy
        h3.Cells(u, "A").PasteSpecial Paste:=xlPasteValues
        h3.Cells(u, "A").PasteSpecial Paste:=xlPasteFormats
        h3.Cells(u, "A").PasteSpecial Paste:=xlPasteColumnWidths
        For i = 1 To rango.Rows.Count
            alto = h2.Rows(i).Height
            h3.Rows(i).RowHeight = alto
        Next
        u = h3.UsedRange.Rows(h3.UsedRange.Rows.Count).Row + 1
        h3.HPageBreaks.Add Before:=h3.Cells(u, "A")
    Next
    '
    ruta = ThisWorkbook.Path & "\"
    h3.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ruta & "empleados.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    h3.Delete
    MsgBox "Archivo empleados.pdf, creado", vbInformation
End Sub

S a l u d o s . D a n t e   A m o r

Recuerda valorar la respuesta.

Hola, buenos días. Está casi perfecto, la única pega es que la primera persona sale perfecta y a partir de la segunda no mantiene el alto de las filas. Te adjunto dos imágenes para que lo veas. Gracias.

Va la macro actualizada

Sub imprime()
'Por.Dante Amor
    Pregunta = MsgBox("Se van a imprimir TODOS los empleados. ¿ESTÁS SEGURO?", _
        vbQuestion + vbYesNo, "¡¡ OJO !!. Importante")
    If Pregunta = 7 Then End
    '
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set h1 = Sheets("Planificación anual")
    Set h2 = Sheets("Calendario")
    '
    Set h3 = Sheets.Add
    '
    With h3.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.669291338582677)
        .RightMargin = Application.InchesToPoints(0.47244094488189)
        .TopMargin = Application.InchesToPoints(0.275590551181102)
        .BottomMargin = Application.InchesToPoints(0.354330708661417)
        .HeaderMargin = Application.InchesToPoints(0.15748031496063)
        .FooterMargin = Application.InchesToPoints(0.15748031496063)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    '
    For n = 7 To h2.Range("BG3")
        h2.Range("E6") = h1.Range("F" & n)
        'h2.PrintOut Copies:=1, Collate:=True
        u = h3.UsedRange.Rows(h3.UsedRange.Rows.Count).Row + 1
        If u = 2 Then u = 1
        Set rango = Range("A1:AD40")
        h2.Range(rango.Address).Copy
        h3.Cells(u, "A").PasteSpecial Paste:=xlPasteValues
        h3.Cells(u, "A").PasteSpecial Paste:=xlPasteFormats
        h3.Cells(u, "A").PasteSpecial Paste:=xlPasteColumnWidths
        For i = 1 To rango.Rows.Count
            alto = h2.Rows(i).Height
            h3.Rows(u).RowHeight = alto
            u = u + 1
        Next
        u = h3.UsedRange.Rows(h3.UsedRange.Rows.Count).Row + 1
        h3.HPageBreaks.Add Before:=h3.Cells(u, "A")
    Next
    '
    ruta = ThisWorkbook.Path & "\"
    h3.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ruta & "empleados.pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    h3.Delete
    MsgBox "Archivo empleados.pdf, creado", vbInformation
End Sub

S a l u d o s . D a n t e   A m o r

Recuerda valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas