Pivot Table Copy Marco HELP!!!!!

[ncalenti]

Hey All-
Im having some problems with some code, and I am hoping one of the macro experts can help me out.
Right now I have a workbook with multiple worksheets with pivot tables. This macro is supposed to copy values and formats of each sheet selected by a checkbox in a dialog into a new workbook. It works almost perfectly, but the problem is as follows:
The pivot table formats dont copy. The tables are formatted using excels built in pivot table formats and a copy past formats on the entire sheet does not copy them over. Some research has told me that this is something with 2007 and up, and I have also discovered that if you only select the cells in the pivot table and paste formats, then it does work. I just dont know how to implement the fix in the macro. Thanks in advance for all the help:

Private Sub CommandButton1_Click()
    Dim cCount As Control, wbNew As Workbook, MyFile As String
    
    'Prompt for File name "C:\Temp" is the default path
    MyFile = Application.GetSaveAsFilename(InitialFileName:="C:\Temp\", _
                                           FileFilter:="Excel Files (*.xls), *.xls", _
                                           Title:="Save Copied Worksheets As...")
    If MyFile = "False" Then Exit Sub 'User canceled
    Application.ScreenUpdating = False
    For Each cCount In Me.Controls
        If TypeName(cCount) = "CheckBox" Then
            If cCount.Value = True Then
                If wbNew Is Nothing Then Set wbNew = Workbooks.Add(xlWBATWorksheet)
                ThisWorkbook.Sheets(cCount.Caption).UsedRange.Copy
                With wbNew.Sheets(wbNew.Sheets.Count)
                    .Range("A1").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
                    .Range("A1").PasteSpecial xlPasteFormats
                    .Range("A1").Select
                    .Name = cCount.Caption
                    wbNew.Sheets.Add After:=wbNew.Sheets(.Index)
                End With
                Application.CutCopyMode = True
            End If
        End If
    Next cCount
    If Not wbNew Is Nothing Then
        Application.DisplayAlerts = False
            wbNew.Sheets(wbNew.Sheets.Count).Delete
        Application.DisplayAlerts = True
        wbNew.Sheets(1).Select
        wbNew.SaveAs Filename:=MyFile
        wbNew.Close False
        MsgBox "Worksheets copied and saved to a new workbook.", vbInformation, "Copy Complete"
    Else: MsgBox "No worksheets were selected to copy. ", vbExclamation, "No Worksheets Copied"
    End If
    Application.ScreenUpdating = True
End Sub

 

[Jerry Sullivan]

You can copy just the PivotTable formats and values using the TableRange2 property.

Try this modification to your code. It assumes you have just one PivotTable per sheet that you want to copy.

On Error Resume Next
For Each cCount In Me.Controls
    If TypeName(cCount) = "CheckBox" Then
        If cCount.Value = True Then
            If wbNew Is Nothing Then Set wbNew = Workbooks.Add(xlWBATWorksheet)
            Set PT = ThisWorkbook.Sheets(cCount.Caption).PivotTables(1)
            If Not PT Is Nothing Then
                PT.TableRange2.Copy
                With wbNew.Sheets(wbNew.Sheets.Count)
                    .Range("A1").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, False, False
                    .Range("A1").PasteSpecial xlPasteFormats
                    .Range("A1").Select
                    .Name = cCount.Caption
                    wbNew.Sheets.Add After:=wbNew.Sheets(.Index)
                End With
                Set PT = Nothing
            End If
            Application.CutCopyMode = True
        End If
    End If
Next cCount