Option Explicit
' </> ------------------------------------------------------------------- </>
' </> ---&--- </> </> ---&--- </>
' </> ---&--- </> C o n v i e r t e a P D F </> ---&--- </>
' </> ---&--- </> </> ---&--- </>
' </> ------------------------------------------------------------------- </>
Sub Mis_PDFs()
Dim Temp As String, Linea As Single, Desti As Single, _
Work As String
Dim Ruta As String, Centro As String, Rango As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Ruta = ThisWorkbook.Path & "\"
' ---&--- Hoja para crear el indice
Sheets.Add After:=ActiveSheet ' -- creo una hoja
Temp = ActiveSheet.Name ' -- Busco el nombre
Columns("A:A").ColumnWidth = 45
' ---&--- Hoja para Imprimir
Sheets("Hoja1").Select Sheets("Hoja1").Copy After:=Sheets(Sheets.Count)
Work = ActiveSheet.Name
Sheets(Work).Select
Cells.Select
Selection.ClearComments
Selection.ClearContents
' ---&--- Selecciona la hoja de plantillas
Sheets("Hoja1").Select
Linea = 9
Desti = 1
While Cells(Linea, 7) <> ""
Sheets(Temp).Cells(Desti, 1) = Cells(Linea, 7) ' --- Centro
Sheets(Temp).Cells(Desti, 2) = Linea ' --- Linea
Linea = Linea + 70
Desti = Desti + 1
DoEvents
Wend
' ---&--- Ahora ordeno la tabla de la hoja que he creado
Sheets(Temp).Select
Columns("A:B").Select
ActiveWorkbook.Worksheets(Temp).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(Temp).Sort.SortFields.Add _
Key:=Range("A:A"), _ SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets(Temp).Sort.SortFields.Add _
Key:=Range("B:B"), _ SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(Temp).Sort
.SetRange Range("A:B") .Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
' ---&--- Ahora creamos PDF
' --- Tomo los datos del primero de la hoja1 y lo copia a la Hoja Work
Centro = Cells(1, 1)
Desti = 1
Rango = "A" & Cells(1, 2) - 8 & ":H" & Cells(1, 2) + 61
Sheets("Hoja1").Range(Rango).Copy Sheets(Work).Range("A" & Desti)
Linea = 2
Desti = Desti + 70
Sheets(Work).Select
Range("I" & Desti).Select ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
ActiveWindow.SelectedSheets.VPageBreaks.Add Before:=ActiveCell
Sheets(Temp).Select
While Cells(Linea, 1) <> ""
If Centro = Cells(Linea, 1) Then
Rango = "A" & Cells(Linea, 2) - 8 & ":H" & Cells(Linea, 2) + 61
Sheets("Hoja1").Range(Rango).Copy Sheets(Work).Range("A" & Desti)
Desti = Desti + 70
Sheets(Work).Select
Range("I" & Desti).Select ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
ActiveWindow.SelectedSheets.VPageBreaks.Add Before:=ActiveCell
Sheets(Temp).Select
Else
Rango = "A1:H" & Desti - 1
Call Crea_PDF(Ruta, Centro, Rango, Temp, Work)
Centro = Cells(Linea, 1)
Desti = 1
Rango = "A" & Cells(Linea, 2) - 8 & ":H" & Cells(Linea, 2) + 61
Sheets("Hoja1").Range(Rango).Copy Sheets(Work).Range("A" & Desti)
Desti = Desti + 70
Sheets(Work).Select
Range("I" & Desti).Select ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=ActiveCell
ActiveWindow.SelectedSheets.VPageBreaks.Add Before:=ActiveCell
Sheets(Temp).Select
End If
Linea = Linea + 1: DoEvents
Wend
' ---&--- Imprimo el ultimo
Rango = "A1:H" & Desti - 1
Call Crea_PDF(Ruta, Centro, Rango, Temp, Work)
' ---&--- Borro la hoja temporal
Sheets(Temp).Delete
Sheets(Work).Delete
Sheets("Hoja1").Select Range("A1").Select
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "Macro finalizara", vbInformation + vbOKOnly, "Crear PDF"
End Sub
' </> --------------------------------------------------------------------- </>
' </> ---&--- </> ---&--- </>
' </> ---&--- </> Crea el PDF ---&--- </>
' </> ---&--- </> ---&--- </>
' </> --------------------------------------------------------------------- </>
Sub Crea_PDF(Ruta, Centro, Rango, Temp, Work)
Sheets(Work).Select
Range(Rango).Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Ruta & Centro, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Sheets(Temp).Select
End Sub
' </> ------------------------------------------------------------------- </>
' </> ---&--- </> </> ---&--- </>
' </> ---&--- </> F I N M A C R O S </> ---&--- </>
' </> ---&--- </> </> ---&--- </>
' </> ------------------------------------------------------------------- </>
