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