Separate worksheets containing pivot tables into individual workbooks with only values

Question

I have one large Excel workbook with multiple worksheets containing pivot tables linked to a big PowerPivot source. I want to save each worksheet separately into workbooks, only as values.

I have managed to do this on a workbook without pivot tables. But I get the following message with this project. I don't want to copy the embedded data for each save as it is crazy slow. Any hints or help?

Option Explicit

Sub JhSeparateSave()
    Dim ws As Worksheet
    Dim NewName As String

    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub

    '       Input box to name new file
    NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

    With Application
        .ScreenUpdating = False

        For Each ws In ThisWorkbook.Worksheets
            If ws.Visible = xlSheetVisible Then
                MsgBox ("Copy step 1")
                ws.Copy

                With ActiveWorkbook.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With

                ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & NewName & "-" & ws.Name
                ActiveWorkbook.Close
                MsgBox ("Saved sheet: " & ws.Name)
            End If
        Next ws

    End With
End Sub

Answer 1

See this example (TESTED AND TRIED).

Option Explicit

Sub JhSeparateSave()
    Dim wbTemp As Workbook
    Dim ws As Worksheet
    Dim NewName As String

    If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
    "New sheets will be pasted as values, named ranges removed" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub

    '~~> Input box to name new file
    NewName = InputBox("Please Specify the name of your new workbook", "New Copy")

    With Application
        .ScreenUpdating = False

        For Each ws In ThisWorkbook.Worksheets
            If ws.Visible = xlSheetVisible Then
                MsgBox ("Copy step 1")
                ws.Copy

                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & ".csv", _
                FileFormat:=xlCSV, CreateBackup:=False

                ActiveWorkbook.Close savechanges:=False

                Set wbTemp = Workbooks.Open(ThisWorkbook.Path & "\" & NewName & ".csv")

                wbTemp.SaveAs Filename:=ThisWorkbook.Path & "\" & NewName & "-" & ws.Name, _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

                wbTemp.Close savechanges:=False

                Kill ThisWorkbook.Path & "\" & NewName & ".csv"

                MsgBox ("Saved sheet: " & ws.Name)
            End If
        Next ws

    End With
End Sub

Answer 2

what i eventually used:

Option Explicit

Sub Copier()

Dim ws As Worksheet
Dim wsNew As Worksheet
Dim NewName As String
Dim wsOriginalName As String

'On Error GoTo Errorcatch

If MsgBox("1. Copy to new sheet. 2. Change to values. 3. Move to new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub

'       Input box to name new file
NewName = InputBox("Please Specify the month name of your new workbook", "New Copy")


With Application
    .ScreenUpdating = False
    .DisplayAlerts = False

    'iterate through all worksheets
    For Each ws In ThisWorkbook.Worksheets

        'ignore hidden worksheets
        If ws.Visible = xlSheetVisible Then

            'copy sheet within original workbook
            wsOriginalName = ws.Name
            ws.Copy After:=Sheets("FAQ")

            'switch to copied sheet
            Set wsNew = ActiveSheet

            'convert to values and format
            With wsNew.UsedRange
                .Copy
                .PasteSpecial xlPasteValuesAndNumberFormats
                .PasteSpecial xlPasteFormats
                .Cells(1, 1).Select
            End With

            'save into new workbook
            wsNew.Copy
            ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & "MIS-FY2013-" & NewName & "-" & wsOriginalName
            ActiveWorkbook.Close

            'MsgBox ("going to try to delete: " & wsNew.Name)
            'delete copied sheet
            wsNew.Delete

         End If
     Next ws

End With

End Sub