Option Explicit
Dim rhojas
Dim cargando
Dim setsh As Worksheet
Private Sub CheckBox7_Click()
Dim i As Long
For i = 0 To ListBox1.ListCount - 1
ListBox1.Selected(i) = CheckBox7
Next
End Sub
Private Sub CommandButton1_Click()
'Por.Dante Amor
Dim Pdfhojas()
Dim HojasOcultas()
Dim hojaactiva As String
Dim n As Double, m As Double, i As Double, ni As Long
Dim wvis As Variant, h As Variant
Dim ruta As String, namePdf As String, nameSh As String
Dim sh2 As Worksheet
Dim wname As Name
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
hojaactiva = ActiveSheet.Name
n = -1
m = -1
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
h = ListBox1.List(i)
n = n + 1
ReDim Preserve Pdfhojas(n)
Pdfhojas(n) = h
wvis = Sheets(h).Visible
If wvis <> -1 Then
m = m + 1
ReDim Preserve HojasOcultas(m)
HojasOcultas(m) = h
Sheets(h).Visible = -1
End If
End If
Next
ruta = TextBox1.Value
If n > -1 Then
'
'Save as PDF
If CheckBox1.Value = True Then
If CheckBox6.Value = False Then
Sheets(Pdfhojas).Select
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & Label2.Caption, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Else
For ni = 0 To UBound(Pdfhojas)
nameSh = CStr(Pdfhojas(ni))
namePdf = TextBox2.Value & Sheets(nameSh).Range(TextBox3.Value).Value & TextBox4.Value & ".pdf"
Sheets(nameSh).ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ruta & namePdf, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Next
End If
End If
'
'Print
If CheckBox2.Value = True Then
Sheets(Pdfhojas).PrintOut
End If
'
'Save as xlsx
Application.CopyObjectsWithCells = False
If CheckBox3.Value = True Then
Application.EnableEvents = False
Sheets(Pdfhojas).Copy
ActiveWorkbook.SaveAs _
Filename:=ruta & Label3.Caption ', _
FileFormat:=xlExcel12, CreateBackup:=False
'Only values and formats
If CheckBox4.Value = True Then
For Each sh2 In ActiveWorkbook.Sheets
sh2.Cells.Copy
sh2.Range("A1").PasteSpecial xlPasteValues
sh2.Range("A1").PasteSpecial xlPasteFormats
Next
End If
'remove named ranges
If CheckBox5.Value = True Then
'On Error Resume Next
For Each wname In ActiveWorkbook.Names
ActiveWorkbook.Names(wname.Name).Delete
Next
'On Error GoTo 0
End If
ActiveWorkbook.Close True
Application.EnableEvents = True
End If
Application.CopyObjectsWithCells = True
'
'Guarda archivo como Binario
'Sheets(hojas).Copy
'ActiveWorkbook.SaveAs _
Filename:=ruta & arch, _
FileFormat:=xlExcel12, CreateBackup:=False
'ActiveWorkbook.Close False
'
'Oculta nuevamente las hojas
If m > -1 Then
Sheets(HojasOcultas).Visible = 0
End If
End If
Sheets(hojaactiva).Select
MsgBox "Finish", vbInformation
End Sub
Private Sub CommandButton2_Click()
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
If .Show <> -1 Then
TextBox1.Value = ThisWorkbook.Path & "\"
Else
TextBox1.Value = .SelectedItems(1) & "\"
End If
End With
End Sub
Private Sub CommandButton3_Click()
Unload Me
End Sub
'
Private Sub ListBox1_Change()
'Por.Dante Amor
Dim i As Double, j As Variant
If cargando Then Exit Sub
cargando = True
For i = 0 To ListBox1.ListCount - 1
For Each j In rhojas
If LCase(ListBox1.List(i)) = LCase(j.Value) Then
ListBox1.Selected(i) = True
Exit For
End If
Next
Next
cargando = False
End Sub
Private Sub TextBox1_Enter()
CommandButton2_Click
End Sub
'
Private Sub UserForm_Activate()
'Por.Dante Amor
Dim rnever As Range, rrango As Range
Dim uc As Double, j As Variant, ini As Double, fin As Double, k As Double
Dim xnum As Variant
Dim existe As Boolean
Dim h As Worksheet
Dim arch As String, archPdf As String, archExcel As String
Set setsh = Sheets("set")
Set rhojas = setsh.Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
Set rnever = setsh.Range("B3:B" & Range("B" & Rows.Count).End(xlUp).Row)
TextBox1.Value = ThisWorkbook.Path & "\"
uc = setsh.Range("C" & Rows.Count).End(xlUp).Row
If uc > 2 Then Set rrango = setsh.Range("C3:C" & uc)
'
cargando = True
arch = "several sheets"
If setsh.Range("D3").Value = "" Then
archPdf = arch
Else
archPdf = setsh.Range("D3").Value
End If
If setsh.Range("E3").Value = "" Then
archExcel = arch
Else
archExcel = setsh.Range("E3").Value
End If
Label2.Caption = Replace(setsh.Range("D3") & ".pdf", "/", "-")
Label3.Caption = Replace(setsh.Range("E3") & ".xlsx", "/", "-")
ListBox1.MultiSelect = 1
ListBox1.ListStyle = 1
For Each h In Sheets
'sheets never select
existe = False
For Each j In rnever
If LCase(h.Name) Like LCase(j.Value) Then
existe = True
Exit For
End If
Next
If existe = False Then
ListBox1.AddItem h.Name
End If
'
'sheets always select
For Each j In rhojas
If LCase(h.Name) = LCase(j.Value) Then
ListBox1.Selected(ListBox1.ListCount - 1) = True
Exit For
End If
Next
'
'sheets select
If uc > 2 Then
For Each j In rrango
xnum = Split(j.Value, "-")
ini = Val(xnum(0))
fin = Val(xnum(UBound(xnum)))
For k = ini To fin
If h.Index = k Then
ListBox1.Selected(ListBox1.ListCount - 1) = True
Exit For
End If
Next
Next
End If
Next
cargando = False
End Sub
