VBA to list specific worksheets in workbook, allowing multiple to be selected and saved to new workbook

[Doug Mutzig]

Good afternoon all,

I have a workbook with 20+ worksheets. Some of the worksheet contain information that an end user may want to email to another person. I currently have it so that you can save select worksheets to a new workbook with only the values and formats of the original workbook saved (no links, etc. between workbooks).

What I would like to do is create the ability for the end user to select multiple worksheets and save them all to one new workbook (values and formats only), by clicking a button that lists the pages with a checkbox to select which ones.

Here is the current code I have for the single page save:

Sub GlobalSaveValuesOnly()Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim y As String, x As String


    x = ActiveWorkbook.Path  'current path of workbook - save location for new workbook
    y = Range("x2") 'location for workbook filename
    
    
    GlobalUnprotect
    
    Application.DisplayAlerts = False
    
   'set the sheet you are copying.
    Set wsCopy = ThisWorkbook.ActiveSheet
    Set wb = Workbooks.Add
    Set wsPaste = wb.Sheets(1)
    
    'Copy everything from copy sheet
    wsCopy.Cells.Copy
    'Paste Values only
    wsPaste.Cells.PasteSpecial xlPasteValues
    wsPaste.Cells.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
           
    'Save new workbook
    
    wsPaste.Name = "Data" 'Change if needed
    wb.SaveAs x & "\" & y & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    ActiveWorkbook.Close SaveChanges:=False
    
    MsgBox ("The data has been saved to a new Workbook in the same location as this workbook")
    Application.DisplayAlerts = True
    
    GlobalProtect
    
End Sub

I have no idea where to go from here to get a button, selection list, and code to save to a new worksheet. Any help on this would be greatly appreciated!

 

[Doug Mutzig]

Hi Dante!

Thank you very much for the info. I have gone through the entire workbook and updated the buttons (selecting "Don't move or size with cells", and unchecking "Print Object"), but when I do the export the buttons are still there. Is there something I am missing?

 

[DanteAmor]

Use this code:

Dim rhojas
Dim cargando
'
Private Sub CommandButton1_Click()
'Por.Dante Amor
    Dim Pdfhojas()
    Dim HojasOcultas()
    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
        arch = "varias hojas"
        '
        'Guarda archivo PDF
        If CheckBox1.Value = True Then
            Sheets(Pdfhojas).Select
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                Filename:=ruta & arch & ".pdf", _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, OpenAfterPublish:=False
        End If
        '
        'Imprime las hojas
        If CheckBox2.Value = True Then
            Sheets(Pdfhojas).PrintOut
        End If
        '
        'Guarda archivo como xlsx
[COLOR=#0000ff]        Application.CopyObjectsWithCells = False[/COLOR]
        If CheckBox3.Value = True Then
            Application.EnableEvents = False
            Sheets(Pdfhojas).Copy
            ActiveWorkbook.SaveAs _
                Filename:=ruta & arch & ".xlsx" ', _
                FileFormat:=xlExcel12, CreateBackup:=False
            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
            ActiveWorkbook.Close True
            Application.EnableEvents = True
        End If
[COLOR=#0000ff]        Application.CopyObjectsWithCells = True[/COLOR]
        '
        '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 ListBox1_Change()
'Por.Dante Amor
    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 UserForm_Activate()
'Por.Dante Amor
    Sheets("set").Select
    Set rhojas = Range("A3:A" & Range("A" & Rows.Count).End(xlUp).Row)
    Set rnever = Range("B3:B" & Range("B" & Rows.Count).End(xlUp).Row)
    
    TextBox1.Value = ThisWorkbook.Path & "\"
    uc = Range("C" & Rows.Count).End(xlUp).Row
    If uc > 2 Then Set rrango = Range("C3:C" & uc)
    '
    cargando = True
    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

 

[Doug Mutzig]

Dante you are absolutly amazing! This works perfectly!!!! Thank you!!!

The last piece I am working on is removing the named ranges from the newly create workbook. I have been playing with some code and gotten it to work relatively well; however, I have encountered an issue where I need to have the macro called go to the originating workbook which could have a different name depending on which department it is in. I.e. the originating workbook could be MBU-TrackingWorkbook.xlsm, SPD-TrackingWorkbook.xlsm, etc. I found some code on this site that I think will work and have asked a followup question there : https://www.mrexcel.com/forum/excel-questions/51660-calling-macro-another-workbook-4.html.

However, thinking about the issue I wanted to ask you if it is possible to copy of only one macro (the one to remove named ranges) during the workbook/sheets save process? This would enable the macro to run regardless of the workbook.

Again, thank you for all your help on this!

 

[DanteAmor]

Do you want "a macro" in the new book?

 

[DanteAmor]

You have to try the latest version:

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

 

[Doug Mutzig]

Hi Dante,

Absolutely Perfect! This is exactly what I need. Thank you very much for all your work on this!

 

[DanteAmor]

I'm glad to help you. I appreciate your kind comments.