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!

 

[DanteAmor]

To start check this thread
https://www.mrexcel.com/forum/excel-questions/1084105-vba-print-multiple-sheets.html

Download the file and review it.

Then we made the necessary adjustments

 

[DanteAmor]

I made some changes to paste only values ​​and formats, try this file:

https://www.dropbox.com/s/8p05n2ui9...ro de Excel a imprimir o archivo v2.xlsm?dl=0

 

[Doug Mutzig]

Hi Dante,

This is exactly what I need! Thank you!!!

Thank you again for such a wonderful fix!

Is there any way to have the save dialog open so that the end users can select where to save?

 

[DanteAmor]

Try with next file, In the form there is a button to select the folder

https://www.dropbox.com/s/s64anu7q5...ro de Excel a imprimir o archivo v2.xlsm?dl=0

 

[Doug Mutzig]

Hi Dante,

I am encountering an issue where the macros for the page are also being saved when I select Excel and Values & Formats only which is causing issues. Would you happen to know what is happening? Also can it be set to always save as values and formats and not have it as an option?

Thank you again for your help on this!

 

[DanteAmor]

I am trying to have an app with some general considerations, it is impossible to cover all occurrences. But I can add them.

In this code I made the adjustment so that the macros of the sheets do not run during copying.

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
        If CheckBox3.Value = True Then
[COLOR=#0000ff]            Application.EnableEvents = False[/COLOR]
            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
[COLOR=#0000ff]            Application.EnableEvents = True[/COLOR]
        End If



        '
        '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]

Hi Dante,

Wow! Works great!!! Thank you!

Couple of other questions:
1. For column C I do not understand what I should put here (range of number of sheets?).
2. I have several buttons (both command and form) on my worksheets that get copied over. The issue is that they are still linked to the original workbook. Is there a way to not copy over the buttons, remove the buttons from the new workbook, or limit the range of what is copied over for each page?

I cannot thank you enough for all your help on this!!

sorry replied to your other thread as well, but wanted to make sure we keep everything in one conversation.

 

[Doug Mutzig]

I do have a button on a few pages that allows the end user to save only that page to an excel workbook. This does the save without the buttons or macros which is great as that means there are no links between the two workbooks and you do not get the nasty message about external links and updating them. The issue is that it only works on one page. I was trying to see if there was a way to modify the code for checkbox 3 & 4 to do something similar. for my use check box 4 could be removed and the code for checkbox 3 & 4 combined as I never want the end user to save an excel file without it saving as only values and formats. below is the code I have (sorry I have forgotten where I got it from). The GlobalUpdates and Globalprotect call other macros to unprotect sheets and stop display updates, etc.

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
    
    GlobalUpdates_Off
    
    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" & vbNewLine & "Click OK to continue")
    'Application.DisplayAlerts = True
    
    GlobalProtect
    
    GlobalUpates_On
    
End Sub

Do you think it is possible to combine checkboxes 3 & 4 into one option? Again, THANK YOU for everything! I am very lost on this and only know enough to really screw things up.

 

[DanteAmor]

sorry replied to your other thread as well, but wanted to make sure we keep everything in one conversation.

Do not worry, we're still in this thread

Originally Posted by Doug Mutzig
1. For column C I do not understand what I should put here (range of number of sheets?).



For example, if you have 100 sheets and you want to select from sheet 20 to sheet 50 then in cell C3 you put 20-50.
If you also want from sheet 55 to 60, then in C4 you put 55-60. When you open the form those sheets will be marked.


2. I have several buttons (both command and form) on my worksheets that get copied over.


Select the button, right click on the button, in properties check the option: "Dont move or size with cells"


Also uncheck the "Print object" option

Check the new version:
https://www.dropbox.com/s/o1ds2w93cucs6c5/Send%20multiple%20sheets%20to%20PDF-Print-File%20v3.xlsm?dl=0