Breaking out a pivot table to new workbooks

[Emily2]

Hi,

I am trying to run a macro where it will filter the pivot table, and create a new workbook for each filtered item.
I have found a macro that works great for doing exactly what i want but creates new worksheet, not a new workbook. I have tried altering a few things but nothing is working?

Any help would be greatly appreciated!

Many thanks

Emily

Sub CopyPivData2()

Dim PT As PivotTable
Dim PI As PivotItem
Dim PI2 As PivotItem





MyWs = "Monthly Summary"


MyPIV = "PivotTable1"


MyField = "Principle investigator"

Set PT = Worksheets(MyWs).PivotTables(MyPIV)
With PT

For Each PI In Worksheets(MyWs).PivotTables(MyPIV).PivotFields(MyField).PivotItems
PI.Visible = True

For Each PI2 In Worksheets(MyWs).PivotTables(MyPIV).PivotFields(MyField).PivotItems
If Not PI2.Name = PI.Name Then PI2.Visible = False
Next PI2
Set NewWs = Worksheets.Add
NewWs.Name = PI & " Monthly"




Worksheets(MyWs).Range("A1:Z345").Copy

'This pastes into cell A1 of the new sheet
NewWs.Range("A1").Select
ActiveSheet.Paste
Next PI



Application.ScreenUpdating = False
Dim wkSt As String
Dim wkBk As Worksheet
wkSt = ActiveSheet.Name
For Each wkBk In ActiveWorkbook.Worksheets
On Error Resume Next
wkBk.Activate
Cells.EntireColumn.AutoFit
Next wkBk
Sheets(wkSt).Select
Application.ScreenUpdating = True
End With
End Sub

[Paul_Hossler]

1. Not tested

2. When dealing with multiple workbooks, I've found I make fewer mistakes by Dim-ing and always explicitly referencing the correct workbook (wbOld and wbNew)

3. You do have to be careful with the .Activate for some things so I might not have the .Activates correct

4. BTW, if you click the [#] icon, you can paste your code between the [...] and [/...] tags to format it pretty

Option Explicit

Sub CopyPivData2()
    Dim wbNew As Workbook, wbOld As Workbook
    Dim wsNew As Worksheet, wsOld As Worksheet, ws As Worksheet
    Dim MyPIV As String, MyField As String
    
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim PI2 As PivotItem
    
    Application.ScreenUpdating = False
    
    Set wbOld = ThisWorkbook
    Set wbNew = Workbooks.Add
    
    wsOld.Activate
    Set wsOld = wbOld.Worksheets("Monthly Summary")
    
    MyPIV = "PivotTable1"
    MyField = "Principle investigator"
    Set PT = Worksheets(wsOld).PivotTables(MyPIV)
 
    With PT
        For Each PI In wsOld.PivotTables(MyPIV).PivotFields(MyField).PivotItems
            PI.Visible = True
    
            For Each PI2 In wsOld.PivotTables(MyPIV).PivotFields(MyField).PivotItems
                If Not PI2.Name = PI.Name Then PI2.Visible = False
            Next PI2
     
            wbNew.Activate
            Set wsNew = wbNew.Worksheets.Add
            wsNew.Name = PI & " Monthly"
     
            wbOld.Activate
            wsOld.Range("A1:Z345").Copy
    
            'This pastes into cell A1 of the new sheet
            wbNew.Activate
            wsNew.Range("A1").Select
            Selection.Paste
        Next PI
    End With
    
    wbNew.Activate
    For Each ws In wbNew.Worksheets
        Cells.EntireColumn.AutoFit
    Next
 
    Application.ScreenUpdating = True
 
 
 End Sub

[Emily2]

Thank you Paul

I have an error coming up with errror 13, type mismatch on this line

Set PT = Worksheets(wsOld).PivotTables(MyPIV)

Any ideas?

[Paul_Hossler]

Set PT = wsOld.PivotTables(MyPIV)

My Bad

I did say it wasn't tested

[Emily2]

great thank you, this works fine, except, i need a new workbook, for each Principle investigator, not one new workbook with each PI on a different tab. any ideas how i can get around this?
it is so that i can send each investigator a workbook report?

Thanks for your help!

Emily

[Paul_Hossler]

Try something like this. I think I have the order of steps right

BTW -- I don't like to hard code ranges like

wsOld.Range("A1:Z345").Copy

Is it always that, or could something like wsOld.Cells(1,1).Currentregion.Copy work?

Option Explicit
 
Sub CopyPivData2_mark2()
    Dim wbNew As Workbook, wbOld As Workbook
    Dim wsNew As Worksheet, wsOld As Worksheet, ws As Worksheet
    Dim MyPIV As String, MyField As String
    Dim sOldPath As String, sNewPath As String
     
    Dim PT As PivotTable
    Dim PI As PivotItem
    Dim PI2 As PivotItem
     
    Application.ScreenUpdating = False
     
    Set wbOld = ThisWorkbook
    sOldPath = wbOld.Path
     
    wsOld.Activate
    Set wsOld = wbOld.Worksheets("Monthly Summary")
     
    MyPIV = "PivotTable1"
    MyField = "Principle investigator"
    Set PT = wsOld.PivotTables(MyPIV)
     
    With PT
        For Each PI In wsOld.PivotTables(MyPIV).PivotFields(MyField).PivotItems
            PI.Visible = True
             
            For Each PI2 In wsOld.PivotTables(MyPIV).PivotFields(MyField).PivotItems
                If Not PI2.Name = PI.Name Then PI2.Visible = False
            Next PI2
             
            'add new WB
            Set wbNew = Workbooks.Add
            wbNew.Activate
            
            Set wsNew = wbNew.Worksheets.Add
            wsNew.Name = PI & " Monthly"
             
            wbOld.Activate
            wsOld.Range("A1:Z345").Copy
             
             'This pastes into cell A1 of the new sheet
            wbNew.Activate
            wsNew.Range("A1").Select
            Selection.Paste
        
            'format a little
            wsNew.Cells.EntireColumn.AutoFit
        
            'delete any blank WS that might have been created
            On Error Resume Next
            Application.DisplayAlerts = False
            For Each ws In wbNew.Worksheets
                If ws.Name <> PI & " Monthly" Then ws.Delete
            Next
            Application.DisplayAlerts = True
            On Error GoTo 0
            
            
            'build name = this path + / + PI
            sNewPath = wbOld.Path & Application.PathSeparator & PI & ".xlsx"
            
            'delete new WB if its there
            On Error Resume Next
            Application.DisplayAlerts = False
            Kill sNewPath
            Application.DisplayAlerts = True
            On Error GoTo 0
            
            'save and close new PI WB
            wbNew.SaveAs (sNewPath)
            wbNew.Close (False)
        
        Next PI
    End With
     
     
    Application.ScreenUpdating = True
     
     
End Sub

[Emily2]

thank you, i have now solved this

Thank you for your help