Select specific worksheets and save to a new workbook

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
350
Hello friends,
I searched a lot on the internet and found countless similar solutions, but not exactly what I was looking for.
I ask for your assistance.
I have a workbook with 38 worksheets.
I made myself a UserForm1 in which I inserted 28 worksheets with their names.
These names are with CheckBox1 so I can choose which ones to copy to a new workbook and then a window pops up with a question: Give the title of the new file you want to save.
For example:
London and London total - I have to click (select) them and press the button in userform1 - Save selected sheets.
And that happens with all the other City and City total I choose.
It may be very easy, but I could not find a solution and help myself.
I ask for your help.
Thanks in advance
P.S. - Or, for example, make it automatically pick up all the worksheets and stack them with CheckBox

Link to sample file:
https://www.dropbox.com/s/94sgbrs99vhyqlf/SAVE IN NEW WORKBOOK.xlsm?dl=0
 
Last edited:

Some videos you may like

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,225
Office Version
2007
Platform
Windows
Use the following file, it has other qualities




Code in userform

Code:
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
--------------------------------
In a module:

Code:
Sub Abrir()
    UserForm1.Show
End Sub
--------------------------------
Just copy the userform and the "set" sheet to your file.

--------------------------------

The book:

https://www.dropbox.com/s/58dkte1leqrq2t4/Send multiple sheets to PDF-Print-File v5.xlsm?dl=0
 

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
350
Hi DanteAmor,
thank you for the file.
I'll look into it, but I think there are too many options I don't need.
I will wait, hoping someone will help me with a simpler version of the example I have given.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,225
Office Version
2007
Platform
Windows
just delete the control you don't want from the form and it's all
 

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
350
just delete the control you don't want from the form and it's all
Code:
[COLOR=#333333] 'Save as xlsx[/COLOR]        
Application.CopyObjectsWithCells = False
        If CheckBox3.Value = True Then
            Application.EnableEvents = False
            Sheets(Pdfhojas).Copy ->>>>>>>>>here give me a error. I dont now, but i thinking this is constant?????
            ActiveWorkbook.SaveAs _
                Filename:=ruta & Label3.Caption   ', _ [COLOR=#333333]                
FileFormat:=xlExcel12, CreateBackup:=False[/COLOR]
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,225
Office Version
2007
Platform
Windows
What does the error message say?
Did you modify something in the macro?
Are the sheets hidden or with a password?
 
Last edited:

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
350
So:
Nothing is locked or hidden.
The problem is that I always have to write which worksheets I want to save in a single file and I also have to write how to spell the file.
I in the main worksheet where all this information is applied I deleted it and that's where the problem comes from.
Your suggestion is very good, but if I have to fill out each worksheet each time and then write down their names (titles), then I will do it the old-fashioned way to choose the desired two files and so on.
I'm trying to say that when I open userform, there is no option to click on the desired files there, but I have to save them in the main worksheet in advance.
I'm not very OK. :)
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,225
Office Version
2007
Platform
Windows
Before you eliminate anything. Try the file exactly as I sent it to you.
When you open the userform there you can select the sheets.

One more thing before starting the userform you can put the name of the future file in cell E3
 

K0st4din

Active Member
Joined
Feb 8, 2012
Messages
350
OK, I tried it and it really came to me - I could choose which files to save.
In this cell E3 I can name the first files (in my case there are two, but the next two will have to change the name)
I'll think about how things will happen.
It seems to me that if we write the file first, and then choose which files, I will still go backwards - forward :)
 

Watch MrExcel Video

Forum statistics

Threads
1,102,842
Messages
5,489,204
Members
407,678
Latest member
Matt1989

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top