Creating New Workbooks from Multiple Worksheets (w/Pivot Tables)

[Mancolt]

I found the following code from Ron de Bruin and have used it with good success until today when I needed to use it with Pivot Tables in Excel 2010. Here is the code from http://www.rondebruin.nl/copy6.htm:

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2010
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook

    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path & "\" & Sourcewb.Name & " " & DateString
    MkDir FolderName

    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets

        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy

            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook

            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2010
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With

            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If


            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With

        End If
GoToNextSheet:
    Next sh

    MsgBox "You can find the files in " & FolderName

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

When using this on a workbook with 30 sheets (all with a pivot table on them) the macro hangs up on this section:

          'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select

In searching the internet, it seems the issue is with the Pivot Table and trying to copy/paste values. So I came across the following macro that is able to copy the Pivot Table as values, which works fine if I do the worksheets one at a time and save them. From http://www.contextures.com/excel-vba...te-format.html:

          Sub PivotCopyFormatValues()
Dim ws As Worksheet
Dim pt As PivotTable
Dim rngPT As Range
Dim rngPTa As Range
Dim rngCopy As Range
Dim rngCopy2 As Range
Dim lRowTop As Long
Dim lRowsPT As Long
Dim lRowPage As Long

On Error Resume Next
Set pt = ActiveCell.PivotTable
Set rngPTa = pt.PageRange
On Error GoTo errHandler

If pt Is Nothing Then
    MsgBox "Could not copy pivot table for active cell"
    GoTo exitHandler
Else
    Set rngPT = pt.TableRange1
    lRowTop = rngPT.Rows(1).Row
    lRowsPT = rngPT.Rows.Count
    Set ws = Worksheets.Add
    Set rngCopy = rngPT.Resize(lRowsPT - 1)
    Set rngCopy2 = rngPT.Rows(lRowsPT)
    
    rngCopy.Copy Destination:=ws.Cells(lRowTop, 1)
    rngCopy2.Copy Destination:=ws.Cells(lRowTop + lRowsPT - 1, 1)
End If

If Not rngPTa Is Nothing Then
    lRowPage = rngPTa.Rows(1).Row
    rngPTa.Copy Destination:=ws.Cells(lRowPage, 1)
End If
    
ws.Columns.AutoFit

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not copy pivot table for active cell"
    Resume exitHandler
End Sub

I was hoping to find a way to incorporate this macro into Ron de Bruin's macro through a Call argument.

'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                Call PivotCopyFormatValues
                Application.CutCopyMode = False
            End If

Doing so works, but each subsequent worksheet overwrites the previous one when saving, and doesn't use the worksheet's name from the original workbook.

Does anyone know of a macro that can accomplish this task, or can you provide any guidance on how to modify the two above macros to do the job? My VBA knowledge is very limited and I haven't been able to figure out where to begin with this one. Both of these macros are much more complex than what I would normally create myself.

I've created a sample file with some fake names and information that may help you to visualize what I'm trying to do. By the end I'd like to have 4 workbooks named Penn State, Pitt, U Penn, Syracuse. The actual file has about 30 sheets instead of 4 and a lot more data.

Thanks in advance for any help you can provide.