Maybe something like:
Sub test() Dim unq As Variant, x As Integer, wb As Workbook unq = Application.Unique(Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange) For x = 1 To UBound(unq) Sheets(Array("Data", "Pivot", "Dashboard")).Copy Set wb = ActiveWorkbook With ActiveSheet.ListObjects("Tabelle1") .Range.AutoFilter Field:=1, Criteria1:="<>" & unq(x, 1), Operator:=xlAnd Application.DisplayAlerts = False .DataBodyRange.SpecialCells(xlVisible).Delete Application.DisplayAlerts = True .Range.AutoFilter Field:=1 End With Sheets("Pivot").PivotTables("PivotTable1").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8) Sheets("Pivot").PivotTables("PivotTable2").ChangePivotCache ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:="Tabelle1", Version:=8) Sheets("Dashboard").Range("C4") = unq(x, 1) wb.SaveAs Filename:=ThisWorkbook.Path & "\" & unq(x, 1) & ".xlsx", FileFormat:=51, Password:=Cells(2, 2) wb.Close False Next x End Sub




Reply With Quote