creating new excel file for each slicer item

[q11]

hello all, is there any ways to write macro about what i want.
at the down part you can see page 1 and page two
i want to creating new excel file for each slicer item with own its data
for example excel MAY must be only with MAY data on the page 2 and on the pivot table page 1

page 1

page 2

 

[John_w]

Are "page 1" and "page 2" the sheet names?

 

[q11]

Are "page 1" and "page 2" the sheet names?

hello "1" and "2" are page names

 

[q11]

hello "1" and "2" are page names

while saying page i mean sheet

 

[John_w]

Your request is a little sparse on detail, but see if the following macro does what you want.

I've made the code as generic as possible, so it doesn't specify sheet names or ranges, etc. The processing is based on the first Slicer Cache and the first Pivot Table in the active workbook, from which the source data range is derived.

You should just need to change the outputFolderPath string to the full folder path where you want the new workbooks for each slicer item to be saved.

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