Copy Pivot Table Values and Format to it own workbook with name of worksheet

SpiderPKT

New Member
Joined
Jan 26, 2018
Messages
1
My goal is to create a file for each Report Filter item with the report filter item as the filename in a Pivot Table. I need to copy the values and the format of the pivot table.

There are 2 ways i have tried
1) i can iterate through the slicer (Code included)
2) Use Excel functionality to create a worksheet for each item in the pivot table.

It is about 350 items in the report filter and Excel sometimes gives me an access violation so I split the loop into 1-200 & 200 - End.

The code is sloppy as it is cobbled together from many posts. Right now it is not putting pasting the output in the File Generic Output, it is writing in the Pivot Table in Grant_PLS.xlsm. Any help would be appreciated. If someone has any easier way I am all ears.


Code:
Sub Step_Thru_SlicerItems_and_Create_Worksheet_1toEnd()'--steps through selecting each item in a specified slicer
'    then saves separate copies of workbook in that state
 Dim i As Long
 Dim slItem As SlicerItem
 Dim sTempFileName As String
 Dim ws As Worksheet
 Dim myDate As Variant
 
 
 
 '--all created files will be saved with filename
 '    of this prefix & slicer name
 Const sFILENAME_PREFIX As String = "Pool Level Summary - "
 Const rpt_title As String = "Pool Level Summary (Inception to Date)"
 myFolder = InputBox("Enter Month Year  -- December 2017")
 myDate = InputBox("Enter Date of Report")
 
 Application.ScreenUpdating = False
 Application.DisplayAlerts = False
 ' Workbooks.Open "C:\Users\lazerwit\Documents\Generic Output.xlsx"
 Workbooks("Grants_PLS.xlsm").Activate
 
 Sheets("GAG").Select
 
 '--save new workbook as a file name - requirement 2
 '--select only first item in SlicerCache Slicer_Grpr Name
 With ActiveWorkbook.SlicerCaches("Slicer_PI")
   '--deselect all items except the first
   .SlicerItems(1).Selected = True
   For Each slItem In .VisibleSlicerItems
      If slItem.Name <> .SlicerItems(1).Name Then _
         slItem.Selected = False
   Next slItem


Dim Last_Row As Long
Last_Row = Range("A" & Rows.Count).End(xlUp).Row
Workbooks("Grants_PLS.xlsm").Activate
Sheets("GAG").Select
Worksheets("GAG").PivotTables("PivotTable1").TableRange1.Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Open "C:\Users\Ian_Surface\Documents\Generic Output.xlsx"
Workbooks("Generic Output.xlsx").Activate
'Worksheets.Add.Name = .SlicerItems(i).Name
Sheets(1).Select
Range("A1").Value = "Report Title"
Range("B1").Value = rpt_title
Range("A2").Value = "Principle Investigator"
Range("B2").Value = .SlicerItems(1).Name
Range("A3").Value = "Report Date"
Range("B3").Value = myDate
Range("A5").Select




Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    ActiveWorkbook.SaveAs Filename:="C:\Report" & "\" & _
 myFolder & " - " & sFILENAME_PREFIX & sCleanFileName(.SlicerItems(1).Name) & ".xls", FileFormat:=xlExcel8
 ActiveWorkbook.Close SaveChanges:=False


  '--step through each item and save copy of workbook with default name
   For i = 2 To .SlicerItems.Count
     .SlicerItems(i).Selected = True
     .SlicerItems(i - 1).Selected = False
    
  Dim pt As PivotTable








Last_Row = Range("A" & Rows.Count).End(xlUp).Row
Workbooks("Grants_PLS.xlsm").Activate
Sheets("GAG").Select
Worksheets("GAG").PivotTables("PivotTable1").TableRange1.Select
Application.CutCopyMode = False
Selection.Copy
Workbooks.Open "C:\Users\lazerwit\Documents\Generic Output.xlsx"
Workbooks("Generic Output.xlsx").Activate
'Worksheets.Add.Name = .SlicerItems(i).Name
Sheets(1).Select
Range("A1").Value = "Report Title"
Range("B1").Value = rpt_title
Range("A2").Value = "Principle Investigator"
Range("B2").Value = .SlicerItems(i).Name
Range("A3").Value = "Report Date"
Range("B3").Value = myDate
Range("A5").Select


Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        
    ActiveWorkbook.SaveAs Filename:="C:\Report" & "\" & _
     myFolder & " - " & sFILENAME_PREFIX & sCleanFileName(.SlicerItems(i).Name) & ".xls", FileFormat:=xlExcel8
 ActiveWorkbook.Close SaveChanges:=False
   Next i
   '--close last saved workbook
'  ActiveWorkbook.Close SaveChanges:=False
 End With
ExitProc:
 '--delete temporary copy of thisworkbook
 'Kill sTempFileName
 Application.ScreenUpdating = True
 Application.DisplayAlerts = True
 '--final state for user
 ThisWorkbook.Activate
 ThisWorkbook.Sheets("GAG").Select
 MsgBox "Workbooks have been saved.", Title:="Process Completed"
End Sub
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.

Forum statistics

Threads
1,215,020
Messages
6,122,712
Members
449,093
Latest member
Mnur

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top