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.
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