Export multiple worksheets without formula with the ability to select exact sheets and location

Question

I have an excel workbook where there is continuosly created new worksheets. Sometimes some of the worksheets has to be preserved and ideally deleted from the workbook. The worksheets also needs to be archived in specific folders on SharePoint.

Right now the following VBA does the trick. Nevertheless, it duplicates every cell from the workbook, which I must then relocate to the proper place.

Option Explicit

Sub WorksheetExport()

    Dim ws As Worksheet
    Dim wsDash As Worksheet
    Dim wbToSave As Workbook
    Dim filePathToSave As String
        
    Application.ScreenUpdating = False
        
    Set wsDash = Worksheets("LAJ")
    
    filePathToSave = "C:\Test\Example\"
    
    For Each ws In ThisWorkbook.Worksheets
    
        If ws.Name <> wsDash.Name Then
        
            ws.Copy
            
            With ActiveSheet.UsedRange.Cells
                
                .Value = .Value
                
            End With
            
            Set wbToSave = ActiveWorkbook
            
            wbToSave.SaveAs _
                Filename:=filePathToSave & wbToSave.Worksheets(1).Name & ".xlsx", _
                FileFormat:=51
        
            wbToSave.Close True
        
        End If
    
    Next ws
    
    Application.ScreenUpdating = True
    
End Sub

If it is possible, I would like to be able to select the precise worksheets to be duplicated or relocated as well as the precise location to which all of the selected worksheets will be transported. Preferably in a dialogue box for user comfort.

Answer 1

Try this:

Sub ExportSheets()
    Dim sheetNames As String
    Dim sheetname
    Dim filePathToSave As String
    Dim FldrPicker As FileDialog
    
    Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)

  With FldrPicker
    .Title = "Select Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub 'Check if user clicked cancel button
    filePathToSave = .SelectedItems(1) & "\"
  End With
    
    sheetNames = InputBox("Enter the sheet name(s) you want to export (separated by semicolon):")

If sheetNames <> "" Then
        Dim wbSource As Workbook
        Set wbSource = ThisWorkbook
        Dim wbDest As Workbook

  If InStr(sheetNames, ";") = 0 Then
            Set wbDest = Workbooks.Add
            wbSource.Sheets(sheetNames).Copy After:=wbDest.Sheets(wbDest.Sheets.Count)
        
            Application.DisplayAlerts = False
            wbDest.SaveAs _
            Filename:=filePathToSave & sheetNames & ".xlsx", _
                FileFormat:=51
            wbDest.Close
            'wbSource.Worksheets(sheetnames).Delete' uncomment if you want to delete the sheet
            Application.DisplayAlerts = True
  Else
        Dim sheetArray As Variant
        sheetArray = Split(sheetNames, ";")
    
         For Each sheetname In sheetArray
            Set wbDest = Workbooks.Add
            wbSource.Sheets(sheetname).Copy After:=wbDest.Sheets(wbDest.Sheets.Count)
        
            Application.DisplayAlerts = False
            wbDest.SaveAs _
            Filename:=filePathToSave & sheetname & ".xlsx", _
                FileFormat:=51
            wbDest.Close
            'wbSource.Worksheets(sheetname).Delete' uncomment if you want to delete the sheet
            Application.DisplayAlerts = True
           Next sheetname
  End If
Else
    Exit Sub
End If

MsgBox "Export complete!"
End Sub