Exporting worksheets to separate workbooks as duplicates vb

Hi @ JPSIMMON

you can try this:

Sub CreateWorkbooks_2()
Dim wbDest As Workbook, wbSource As Workbook
Dim sht As Worksheet
Dim ws As Worksheet
Dim strSavePath As String
Dim r As Long, c As Long
Dim q As Integer
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
strSavePath = "S:\Folder Pathway\Path\Folder Path\"
Set wbSource = ActiveWorkbook
For Each sht In wbSource.Worksheets
    q = MsgBox("Create new book for: " + sht.Name, vbYesNo + vbQuestion, "My Process")
    If q = 6 Then
        r = sht.Rows.Find("*", , , , xlByRows, xlPrevious).Row
        c = sht.Columns.Find("*", , , , xlByColumns, xlPrevious).Column
        sht.Copy
        Set ws = ActiveSheet
        ws.Range("A1").Resize(r, c).Value = sht.Range("A1").Resize(r, c).Value
        Set wbDest = ActiveWorkbook
        wbDest.SaveAs strSavePath & sht.Name
        wbDest.Close

    End If
Next sht
Application.ScreenUpdating = True
ErrorHandler:
End Sub

Hi @JPSIMMON

There are many ways to do that, here I show you one.
First run the code "Sub ListSheets()", it will create aa new sheet, list all the sheets in the book, and place a checkbox for each one.
Then you check all the tabs you want to save, and the you run code "Sub CreateWorkbooks_2()"

Sub ListSheets()
Dim wSht As Worksheet, wCon As Worksheet
Dim i As Integer
i = 0
For Each wSht In Worksheets
    If wSht.Name = "MyControl" Then
        Application.DisplayAlerts = False
        wSht.Delete
        Application.DisplayAlerts = True
    End If
Next wSht
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "MyControl"
Set wCon = Worksheets("MyControl")
For Each wSht In Worksheets
     If wSht.Name <> "MyControl" Then
     i = i + 1
          wCon.Cells(i, 1) = i
          wCon.Cells(i, 2) = wSht.Name
          ActiveSheet.CheckBoxes.Add(Cells(i, 3).Left, _
                                      Cells(i, 3).Top, _
                                      5, 5).Select
          With Selection
              .Caption = ""
              .Value = xlOff '
              .LinkedCell = "D" & i
              .Display3DShading = False
          End With
     End If
Next wSht
wCon.Cells(1, 1).Select
MsgBox "Check the Sheets you want to save" & vbCrLf & "Then run Macro: CreateBooks", , "Record Sheets"
End Sub

Sub CreateWorkbooks_2()
Dim wbDest As Workbook, wbSource As Workbook
Dim Sht As Worksheet, ws As Worksheet, wCon As Worksheet
Dim strSavePath As String
Dim r As Long, c As Long
Dim i As Integer, LastRow As Integer

On Error GoTo ErrorHandler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wCon = Sheets("MyControl")
LastRow = wCon.Cells(wCon.Rows.Count, 1).End(xlUp).Row
strSavePath = "S:\Folder Pathway\Path\Folder Path\"
Set wbSource = ActiveWorkbook

For i = 1 To LastRow
     Set Sht = Worksheets(wCon.Cells(i, 1).Value)
     If wCon.Cells(i, 4).Value = True Then
'          r = Sht.Rows.Find("*", , , , xlByRows, xlPrevious).Row
'          c = Sht.Columns.Find("*", , , , xlByColumns, xlPrevious).Column
'          Sht.Copy
'          Set ws = ActiveSheet
'          ws.Range("A1").Resize(r, c).Value = ws.Range("A1").Resize(r, c).Value
'          Set wbDest = ActiveWorkbook
'          wbDest.SaveAs strSavePath & Sht.Name
'          wbDest.Close
    End If
Next i
wCon.Delete
ErrorHandler:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub