Public Sub Save_Slicer_Items_In_Separate_Workbooks()
Dim outputFolderPath As String
Dim newWbFullName As String, newWbFullNameXlsx As String
Dim sourceWb As Workbook
Dim slCache As SlicerCache
Dim slItem As SlicerItem, slMatch As SlicerItem
Dim pt As PivotTable
Dim newWb As Workbook
Dim newWbSlCache As SlicerCache
Dim newWbPt As PivotTable
Dim ptSourceRange As Range
Dim ptSourceParts As Variant
Dim slicerSourceDataCol As Variant
outputFolderPath = "C:\path\to\folder\" '<------- CHANGE THIS
If Right(outputFolderPath, 1) <> "\" Then outputFolderPath = outputFolderPath & "\"
'The source (input) workbook is the active workbook
Set sourceWb = ActiveWorkbook
Set slCache = sourceWb.SlicerCaches(1)
Application.ScreenUpdating = False
'Loop through each slicer item
For Each slItem In slCache.SlicerItems
'Show all items
slCache.ClearManualFilter
If slItem.HasData Then
'Save a copy of the source workbook with this slicer item as the file name in the output folder. This becomes the new output workbook
With sourceWb
newWbFullName = outputFolderPath & slItem.Name & Mid(.FullName, InStrRev(.FullName, "."))
.SaveCopyAs Filename:=newWbFullName
Set newWb = Workbooks.Open(newWbFullName)
End With
'Select the next slicer item and unselect all the others
For Each slMatch In slCache.SlicerItems
If slItem.Name = slMatch.Name Then slMatch.Selected = True Else: slMatch.Selected = False
Next
Set newWbSlCache = newWb.SlicerCaches(1)
Set newWbPt = newWbSlCache.PivotTables(1)
ptSourceParts = Split(newWbPt.SourceData, "!")
'Set a range object to the pivot table's source data
Set ptSourceRange = newWb.Worksheets(ptSourceParts(0)).Range(Application.ConvertFormula(ptSourceParts(1), xlR1C1, xlA1))
'Find slicer's field name in row 1 of source data and get its column number. This used below to AutoFilter the source data on that column with each
'slicer item
slicerSourceDataCol = Application.Match(newWbSlCache.SourceName, ptSourceRange.Rows(1), 0)
'Filter the source data by this slicer item and delete the rows that don't match it
Filter_and_Delete_Hidden_Rows ptSourceRange, CLng(slicerSourceDataCol), slItem.Name
'Update the pivot table and slicer to remove the deleted slicer items
newWbPt.PivotCache.MissingItemsLimit = xlMissingItemsNone
newWbPt.PivotCache.Refresh
'Optional - if the source workbook is a macro-enabled workbook (.xlsm or .xlsb) and you want to save the output workbooks as .xlsx files instead
If StrComp(Right(newWbFullName, 5), ".xlsm", vbTextCompare) = 0 Or StrComp(Right(newWbFullName, 5), ".xlsb", vbTextCompare) = 0 Then
newWbFullNameXlsx = Left(newWbFullName, InStrRev(newWbFullName, ".")) & "xlsx"
Application.DisplayAlerts = False 'suppress warning
newWb.SaveAs Filename:=newWbFullNameXlsx, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
newWb.Close SaveChanges:=False
Kill newWbFullName
End If
End If
Next
slCache.ClearManualFilter
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Private Sub Filter_and_Delete_Hidden_Rows(filterRange As Range, filterColumnNumber As Long, filterCriteria As String)
Dim visibleAreasList As String
Dim deleteRows As Range
Dim i As Long
With filterRange
.AutoFilter
.AutoFilter Field:=filterColumnNumber, Criteria1:=filterCriteria
'Get addresses of visible rows
visibleAreasList = .SpecialCells(xlCellTypeVisible).Address
'Unfilter the table to show all rows
.AutoFilter
'Find the rows that were hidden and add to deleteRows range
Set deleteRows = Nothing
For i = 1 To .Rows.Count
If Intersect(.Rows(i), .Worksheet.Range(visibleAreasList)) Is Nothing Then
If deleteRows Is Nothing Then
Set deleteRows = .Rows(i)
Else
Set deleteRows = Union(deleteRows, .Rows(i))
End If
End If
Next
'Delete the rows that were hidden
If Not deleteRows Is Nothing Then
deleteRows.EntireRow.Delete
End If
End With
End Sub
