Generar PDF multipáginas desde Excel con foto
Para Dante Amor
Hola. En Enero me ayudaste con la pregunta "Generar PDF multipáginas desde Excel 2002", que funciona perfectamente pero dicha macro no me copia las fotos, logos, imágenes, etc a PDF. ¿Cómo podría modificar la macro para que me lo copiara?.
H o l a:
1. Revisa que las fotos, logos, etc tenga en su propiedad marcada la opción "mover y cambiar tamaño con celdas"
2. Revisa en las opciones de excel, Avanzadas, esté activa la casilla de Cortar, copiar y ordenar objetos junto con las celdas:
Prueba nuevamente la macro.
Si lo anterior no resuelve el problema, envíame tu archivo con las fotos y logos; y con la macro, para probar.
Recuerda poner en el asunto tu nombre de usuario.
':) ':)
Hola Dante
Ayer te mande el fichero.
Un saludo, Ruben.
H o l a:
Te anexo la macro actualizada
Private Sub CommandButton1_Click()
' SE GENERA EL INFORME PDF DE LAS ILLIGS
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Application.StatusBar = False
'
'If MsgBox("TARDA 1 MINUTO EN GENERARSE ESTE INFORME, ¿ESTÁS SEGURO QUE QUIERES CREARLO?," & vbCr & "PULSA ACEPTAR PARA CONTINUAR", vbOKCancel + vbInformation, "Imprimir plantilla") = vbCancel Then Exit Sub
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("ILLIG")
Set h2 = l1.Sheets("IMPRIMIR_ILLIG(RICOH)")
Set l2 = Workbooks.Add
Ruta = "C:\Users\RUBEN\Desktop\"
'Ruta = "C:\trabajo\"
archxls = "FICHERO_TEMPORAL_ILLIG.xls"
archpdf = "FICHAS_ILLIG.pdf"
'
u = h1.Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To u
Application.StatusBar = "PROCESANDO EL REGISTRO: " & i & " de " & u
h1.Rows(i).Copy h2.Rows(3)
h2.Copy after:=l1.Sheets(l1.Sheets.Count)
Set h4 = ActiveSheet
h4.Range("A6:K61").Copy
h4.[A6].PasteSpecial Paste:=xlValues
l2.Sheets.Add after:=l2.Sheets(l2.Sheets.Count)
Set h3 = l2.ActiveSheet
h4.Range("A6:K61").Copy h3.[A1]
h4.Range("A6:K61").Copy
h3.[A1].PasteSpecial Paste:=xlPasteColumnWidths
'
h3.PageSetup.PrintArea = "A1:K61"
'
res h3
h4.Delete
Next
l2.SaveAs Filename:=Ruta & archxls, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'
l2.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Ruta & archpdf, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
l2.Close
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "ARCHIVO PDF CREADO"
End Sub':) ':)
Hola Dante
Respecto a la marca de agua me refería a la imagen que te adjunto y no al texto que pone "Página 1". Solo me sale cuando hago una vista preliminar.
Si se puede hacer que pase la marca de agua también a PDF pues bien y si es complicado o no se puede entonces no me importaría en absoluto. Gracias
Un saludo, Rubén
Te anexo la macro actulaizada
Private Sub CommandButton1_Click()
' SE GENERA EL INFORME PDF DE LAS ILLIGS
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Application.StatusBar = False
'
'If MsgBox("TARDA 1 MINUTO EN GENERARSE ESTE INFORME, ¿ESTÁS SEGURO QUE QUIERES CREARLO?," & vbCr & "PULSA ACEPTAR PARA CONTINUAR", vbOKCancel + vbInformation, "Imprimir plantilla") = vbCancel Then Exit Sub
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("ILLIG")
Set h2 = l1.Sheets("IMPRIMIR_ILLIG(RICOH)")
Set l2 = Workbooks.Add
Ruta = "C:\Users\RUBEN\Desktop\"
Ruta = "C:\trabajo\"
archxls = "FICHERO_TEMPORAL_ILLIG.xls"
archpdf = "FICHAS_ILLIG.pdf"
'
u = h1.Range("A" & Rows.Count).End(xlUp).Row
For i = 4 To u
Application.StatusBar = "PROCESANDO EL REGISTRO: " & i & " de " & u
h1.Rows(i).Copy h2.Rows(3)
h2.Copy after:=l1.Sheets(l1.Sheets.Count)
Set h4 = ActiveSheet
h4.Range("A6:K61").Copy
h4.[A6].PasteSpecial Paste:=xlValues
'
h4.Rows("1:5").Delete
h4.Copy after:=l2.Sheets(l2.Sheets.Count)
'l2.Sheets.Add after:=l2.Sheets(l2.Sheets.Count)
Set h3 = l2.ActiveSheet
'h4.Range("A6:K61").Copy h3.[A1]
'h4.Range("A6:K61").Copy
'h3.[A1].PasteSpecial Paste:=xlPasteColumnWidths
'
h3.PageSetup.PrintArea = "A1:K61"
'
res h3
h4.Delete
Next
l2.SaveAs Filename:=Ruta & archxls, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'
l2.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Ruta & archpdf, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
l2.Close
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "ARCHIVO PDF CREADO"
End Sub
Sub res(h3)
With h3.PageSetup
.LeftHeader = ""
'.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.708661417322835)
.RightMargin = Application.InchesToPoints(0.708661417322835)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.748031496062992)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.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
End Sub':) ':)
Muchas gracias Dante
Excelente trabajo, gracias por vuestras inestimables ayudas que nos hacéis las cosas mucho más fáciles.
