VBA Paste Pivot Table Data to multiple Worksheets Keeping Pivot Table Format

[wiggins2402]

I have created some VBA code to copy multiple Pivot Tables on different tabs and Paste them in a new workbook in a temp file location to be emailed from a list in the source workbook. Everything works well except when I paste the pivot tables it only paste the data and not the format. I have searched multiple web blogs as well as throughout Mr. Excel and could not find a solution that would work. Below is the code I am using and I am probably missing something simple in it. If you know a solution U would be very grateful.

Sub ExportPivotTables()


    Dim terr As String
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim MyMonth As String
    Dim MyYear As String
    Dim SubjectLine As String
    Dim FileFormatNum As Long
    Dim row As Integer
    
    ' Email Subject line.
    MyMonth = Format(DateAdd("m", -1, Date), "mmmm")
    MyYear = CStr(Format(DateAdd("m", -1, Date), "yyyy"))
    SubjectLine = MyMonth + " " + MyYear + " Weidmuller Region Sales Report "
    FileFormatNum = 51
    FileExtStr = ".xlsx"
    row = 2
    On Error Resume Next


    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Worksheets("Regions").Activate
      ActiveSheet.Cells(row, 1).Select
      Do Until ActiveCell.Value = "End"
        terr = ActiveCell.Value
        ActiveSheet.Cells(row, 2).Select
        Email = ActiveCell.Value
        
        Sheets("Region Overview").Select
        ActiveSheet.PivotTables ("Region Overview")
        ActiveSheet.PivotTables("Region Overview").PivotFields("Region").ClearAllFilters
        ActiveSheet.PivotTables("Region Overview").PivotFields("Region").CurrentPage = terr
    
        
        TempFilePath = Environ$("temp") & "\"
        TempFileName = "Sales Report (" + terr + ")"


        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)


            Call CopyPivotValues(TempFilePath & TempFileName & FileExtStr, ActiveWorkbook)
            On Error Resume Next
            With OutMail
                .To = Email
                .CC = ""
                .BCC = ""
                .Subject = SubjectLine
                .Body = "Sales Team, Attached is your Sales report for the previous month for your territory."
                                               
                
                .Attachments.Add TempFilePath & TempFileName & FileExtStr
                .send
            End With
            On Error GoTo 0
            
        Kill TempFilePath & TempFileName & FileExtStr
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    
        Worksheets("Regions").Activate
        row = row + 1
        ActiveSheet.Cells(row, 1).Select
        
    Loop
End Sub


Sub CopyPivotValues(fname As String, sWB As Workbook)
    Dim dWB As Workbook
    Dim MySheets, i As Long, ws As Worksheet, Rng As Range
     
    MySheets = Array("Region Overview", "Region Totals", "Region Totals by Customer Type", "Territory Totals", "Territory Totals by Cus Type", "DIR(POP) Sales", "DIS(POP) Sales", "POS Disty Summary", "POS Disty POS Sales w-Customer", "POP Disty POS Sales w-Customer", "Samples")
     


    Set dWB = Workbooks.Add


     
    Const NewwbName As String = "Territory Sales Report"
    With Application
        .ScreenUpdating = 0
        .DisplayAlerts = 0
    End With
    For i = 0 To UBound(MySheets)
        On Error Resume Next
        Set ws = dWB.Sheets(MySheets(i))
        On Error GoTo 0
        With sWB.Sheets(MySheets(i))
            Set Rng = .Range("a1", .Range("a1").SpecialCells(xlCellTypeLastCell))
            Rng.UnMerge
        End With
        With dWB
            If ws Is Nothing Then
                Set ws = Sheets.Add
                ws.Move After:=Sheets(dWB.Sheets.Count)
                ws.Name = MySheets(i)
            End If
            Rng.Copy
            ws.Range("a1").PasteSpecial xlFormats
            ws.Range("a1").PasteSpecial xlValues
            ws.Range("a1").PasteSpecial xlPasteColumnWidths
            
            Set ws = Nothing
            Set Rng = Nothing
        End With
        
    Next
    dWB.Sheets(1).Delete
    dWB.SaveAs Filename:=fname
    dWB.Close False
    With Application
        .ScreenUpdating = 1
        .DisplayAlerts = 1
    End With
End Sub

 

[SpillerBD]

Copying the values is what your sub CopyPivotValues does.

ws.Range("a1").PasteSpecial xlFormats
            ws.Range("a1").PasteSpecial [B]xlValues[/B]
            ws.Range("a1").PasteSpecial xlPasteColumnWidths

You'd be better of copying the whole sheet with the Pivot Table on it. However, I assume the ideal of copying the values is because each recipient may not be intended to see the entire data set, just the data that pertains to them.

 

[wiggins2402]

You are correct as the VBA loops through the source list and changes the filters on the pivot tables and send that information to specific individuals who do not need to see the others data. Is it possible to copy the sheets and then kill the link to the source data? this would be preferable as I intend to include charts and graphs as well with the pivot tables. I am new to VBA and have had a friend help compile what I have so far.

 

[SpillerBD]

If you already have the desired filter for the individual reports in the Pivot Tables Filter area you're almost there.
In the Pivot Table Options, under the Data tab, deselect the "Save source data with File"
Then, from the Options drop-down, click the "Show Report Filter Pages" (the resulting sheet names will be based on the filtered field. If a name is too long you'll get a "Sheet#" instead.)
Select all the resultant Sheets as a Group.
To send copies of the selected sheets to Folder of your choosing, run this:

'SpltSheets
Sub SplitSelectedWorkSheets()
    Dim ws As Worksheet
    Dim DisplayStatusBar As Boolean
    Dim DestinationPath As Variant
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Select a destination folder or create a new destination."
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Cancelled"
            Exit Sub
        Else
            'MsgBox .SelectedItems(1)
            DestinationPath = .SelectedItems(1)
        End If
    End With
    
    DisplayStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.StatusBar = ActiveWindow.SelectedSheets.Count & " Remaining Sheets"
    
    For Each ws In ActiveWindow.SelectedSheets
        Dim NewFileName As String
       
        'Macro-Enabled
        'NewFileName = ThisWorkbook.Path & "\" & ws.Name & ".xlsm"
        'Not Macro-Enabled
            NewFileName = DestinationPath & "\" & ws.Name & ".xlsx"
            ws.Copy
            'ActiveWorkbook.Sheets(1).Name = "Sheet1"
            'ActiveWorkbook.SaveAs Filename:=NewFileName, _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled
            ActiveWorkbook.SaveAs FileName:=NewFileName, _
                FileFormat:=xlOpenXMLWorkbook
            ActiveWorkbook.Close SaveChanges:=False
    Next
    
    Application.DisplayAlerts = True
    Application.StatusBar = False
    Application.DisplayStatusBar = DisplayStatusBar
    Application.ScreenUpdating = True
    Close 'close all files and folders?
End Sub