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

Doug Mutzig

Board Regular
Joined
Jan 1, 2019
Messages
50
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:
Code:
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

Board Regular
Joined
Jan 1, 2019
Messages
50
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?
 

Some videos you may like

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Use this code:

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

Board Regular
Joined
Jan 1, 2019
Messages
50
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Do you want "a macro" in the new book?
 

Doug Mutzig

Board Regular
Joined
Jan 1, 2019
Messages
50
Hi Dante,

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. I appreciate your kind comments.
 

Watch MrExcel Video

Forum statistics

Threads
1,114,235
Messages
5,546,649
Members
410,752
Latest member
MC01_
Top