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\"
If Right(outputFolderPath, 1) <> "\" Then outputFolderPath = outputFolderPath & "\"
Set sourceWb = ActiveWorkbook
Set slCache = sourceWb.SlicerCaches(1)
Application.ScreenUpdating = False
For Each slItem In slCache.SlicerItems
slCache.ClearManualFilter
If slItem.HasData Then
With sourceWb
newWbFullName = outputFolderPath & slItem.Name & Mid(.FullName, InStrRev(.FullName, "."))
.SaveCopyAs Filename:=newWbFullName
Set newWb = Workbooks.Open(newWbFullName)
End With
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 ptSourceRange = newWb.Worksheets(ptSourceParts(0)).Range(Application.ConvertFormula(ptSourceParts(1), xlR1C1, xlA1))
slicerSourceDataCol = Application.Match(newWbSlCache.SourceName, ptSourceRange.Rows(1), 0)
Filter_and_Delete_Hidden_Rows ptSourceRange, CLng(slicerSourceDataCol), slItem.Name
newWbPt.PivotCache.MissingItemsLimit = xlMissingItemsNone
newWbPt.PivotCache.Refresh
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
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
visibleAreasList = .SpecialCells(xlCellTypeVisible).Address
.AutoFilter
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
If Not deleteRows Is Nothing Then
deleteRows.EntireRow.Delete
End If
End With
End Sub