VBA to loop through sheets and copy to new workbook including the pivot tab

[simont1975]

Hi,

Apologies if this has been asked before, I wasn't able to find anything similar.

I have code that loops through all worksheets except certain sheets and will save a copy of the sheet to a new workbook. (code below). What I'm trying to do is do exactly the same but also attach the pivot tab to the new workbook and ensure the pivot cache is only looking at the new data.

My currently VBA (Which works, but id like to also copy the pivot tab to each newly save workbook based on the looping of the worksheets except those identified)

'Save Sheets for Handlers into Folder
Sub SaveShtsAsBook_NEW()
Dim Sheet As Worksheet, SheetName$, MyFilePath$, N&
MyFilePath$ = ActiveWorkbook.Path & "\" & _
Left(Range("A1").Value, Len(Range("A1").Value))
'Above is the name of the folder created to store the Debtor Files

With Application
.ScreenUpdating = False
.DisplayAlerts = False
' End With
On Error Resume Next '<< a folder exists
MkDir MyFilePath '<< create a folder


For Each Sheet In Worksheets
If Sheet.Name <> "Refresh" And Sheet.Name <> "PIVOT" And Sheet.Name <> "IBA CL064 - DATA" And Sheet.Name <> "AGE_MAP" And Sheet.Name <> "BU Mapping" And Sheet.Name <> "BU Listing" And Sheet.Name <> "IBA_Acct_Hand" And Sheet.Name <> "OPS_Mapping" And Sheet.Name <> "FO_Acct_Hand_by_Pol" And Sheet.Name <> "TeamName_Mapping" Then
Sheet.Copy
With ActiveWorkbook
With .ActiveSheet
[A1].Select
SheetName = ActiveSheet.Name
End With
.SaveAs Filename:=MyFilePath _
& "\" & SheetName & ".xlsx"
.Close SaveChanges:=True
End With
.CutCopyMode = False
End If
Next
End With

Worksheets("IBA CL064 - DATA").Activate
Range("AR:AR").Clear

End Sub