Split Workwook and save

[georgiboy]

Below is the code that was exactly the same but i removed the need to use version 2302:

Sub test()
    Dim x As Integer
    Dim wb As Workbook
    Dim rCell As Range
    Dim c As New Collection
    Dim col As Variant
    
    On Error Resume Next
    For Each rCell In Tabelle1.ListObjects("Tabelle1").ListColumns("Team").DataBodyRange.Cells
        c.Add rCell.Value, CStr(rCell.Value)
    Next rCell
    On Error GoTo 0
    
    For Each col In c
        Sheets(Array("Data", "Pivot", "Dashboard")).Copy
        Set wb = ActiveWorkbook
        With ActiveSheet.ListObjects("Tabelle1")
            .Range.AutoFilter Field:=1, Criteria1:="<>" & col, 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") = col
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & col & ".xlsx", FileFormat:=51, Password:=Cells(2, 2)
        wb.Close False
    Next col
End Sub