PDA

View Full Version : Breaking out a pivot table to new workbooks



Emily2
06-30-2015, 04:36 AM
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
06-30-2015, 07:43 AM
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
06-30-2015, 08:05 AM
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
06-30-2015, 08:13 AM
Set PT = wsOld.PivotTables(MyPIV)


My Bad

I did say it wasn't tested :devil2:

Emily2
06-30-2015, 08:29 AM
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
06-30-2015, 09:44 AM
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
07-03-2015, 01:36 AM
thank you, i have now solved this

Thank you for your help