Guardar un archivo pdf con todas las hojas del libro
Tengo una macro que me guarda todas las hojas seleccionadas del libro como PDF, y me las da a elegir incluso las hojas ocultas (quisiera que no se muestren las hojas ocultas), pero tampoco respeta los margenes o escala que tienen las hojas y salen mal, desproporcionado a la hora de imprimir, la macro es la siguiente :
Sub CommandButton1_Click()
'GUARDA LAS HOJAS COMPLETAS PREVIAMENTE SELECCIONADAS
Dim hoja As Control
x = 0
For Each hoja In Me.Controls
If Not hoja.Name = "CommandButton1" Then
x = x + 1
If hoja.Value = True Then
Worksheets(hoja.Caption).PageSetup.LeftFooter = hoja.Caption
If a = 1 Then ren = "False" Else ren = "True"
Worksheets(hoja.Caption).Select Replace:=ren
a = 1
End If
End If
Next
On Error Resume Next
'nbre = "Prueba " & Format(Date, "dd-mm-yyyy" & " " & Format(Time(), "hh-mm-ss")) '"Prueba1" O TAMBIÉN:
'nbre = InputBox("Escribe el nombre con el que quieres guardar:", "Guardar archivo") & " " & Format(Date, "dd-mm-yyyy" & " " & Format(Time(), "hh-mm-ss"))
nbre = Trim(InputBox(" Registre un Nombre ")) & Format(Date, "dd-mm-yyyy" & " " & Format(Time(), "hh-mm-ss"))
Set wb = ActiveWorkbook
With wb
RutaArchivo = ThisWorkbook.Path & "\" & nbre & ".pdf" '<==================================Ruta archivo
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
RutaArchivo, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=True, OpenAfterPublish:=True
'Sheets(1).Select
Unload Me
End With
End Sub
Private Sub marca_Click()
Dim check As Control
For Each check In Me.Controls
On Error Resume Next
If Not check.Name = "marca" And Not check.Name = "CommandButton1" Then
If check = True Then check = False: marca.Caption = "Marcar Todos" Else _
check = True: marca.Caption = "Desmarcar Todos"
End If
Next
End Sub
Private Sub UserForm_Activate()
Dim cCntrl As Control
Dim oSheet As Object
x = 60
For Each oSheet In Sheets
Set cCntrl = Me.Controls.Add("Forms.checkbox.1", , True)
With cCntrl
.Caption = oSheet.Name
.Width = Me.Width
.Height = 15
.Top = x
.Left = 18
.Value = True
End With
x = x + 15 'Separación entre cada item
Next
Me.Height = x + 36
End Sub
1 respuesta
H o l a:
Envíame tu archivo para revisar las macros.
Mi correo [email protected]
En el asunto del correo escribe tu nombre de usuario “Daniel Herrera Flores” y el título de esta pregunta.
H o l a:
Para que en el userform solamente se vean las visibles, agregué la instrucción If oSheet.Visible = -1 Then:
Private Sub UserForm_Activate()
Dim cCntrl As Control
Dim oSheet As Object
x = 60
For Each oSheet In Sheets
If oSheet.Visible = -1 Then
Set cCntrl = Me.Controls.Add("Forms.checkbox.1", , True)
With cCntrl
.Caption = oSheet.Name
.Width = Me.Width
.Height = 15
.Top = x
.Left = 18
.Value = True
End With
x = x + 15 'Separación entre cada item
End If
Next
Me.Height = x + 36
End SubPara que te respete el tamaño de la impresión; tenías el parámetro IgnorePrintAreas:=True, hay que cambiarlo a False:
Sub CommandButton1_Click()
'GUARDA LAS HOJAS COMPLETAS PREVIAMENTE SELECCIONADAS
Dim hoja As Control
x = 0
For Each hoja In Me.Controls
If Not hoja.Name = "CommandButton1" Then
x = x + 1
If hoja.Value = True Then
Worksheets(hoja.Caption).PageSetup.LeftFooter = hoja.Caption
If a = 1 Then ren = "False" Else ren = "True"
Worksheets(hoja.Caption).Select Replace:=ren
a = 1
End If
End If
Next
On Error Resume Next
'nbre = "Prueba " & Format(Date, "dd-mm-yyyy" & " " & Format(Time(), "hh-mm-ss")) '"Prueba1" O TAMBIÉN:
'nbre = InputBox("Escribe el nombre con el que quieres guardar:", "Guardar archivo") & " " & Format(Date, "dd-mm-yyyy" & " " & Format(Time(), "hh-mm-ss"))
nbre = Trim(InputBox(" Registre un Nombre ")) & Format(Date, "dd-mm-yyyy" & " " & Format(Time(), "hh-mm-ss"))
Set wb = ActiveWorkbook
With wb
RutaArchivo = ThisWorkbook.Path & "\" & nbre & ".pdf" '<==================================Ruta archivo
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=RutaArchivo, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
'Sheets(1).Select
Unload Me
End With
End Sub