Hi Bart

This example have a sheet with the data named "Sheet1" and before it split the data it delete the columns you want in this sheet
I will add a sum formula in column C of every sheet it create

Maybe you want to change the column in the filter range ?
Set rng = ws1.Range("A1:IV" & Rows.Count)

Sub Copy_With_AdvancedFilter_To_Worksheets()
   Dim CalcMode As Long
   Dim ws1 As Worksheet
   Dim ws2 As Worksheet
   Dim WSNew As Worksheet
   Dim rng As Range
   Dim cell As Range
   Dim Lrow As Long

   Set ws1 = Sheets("Sheet1")  '<<< Change

   With ws1
       .Range("Z:AH").Delete Shift:=xlShiftToLeft
       .Range("W:W").Delete Shift:=xlShiftToLeft
       .Range("L:M").Delete Shift:=xlShiftToLeft
       .Range("F:J").Delete Shift:=xlShiftToLeft
   End With

   'Set filter range : A1 is the top left cell of your filter range and
   'the header of the first column, D is the last column in the filter range
   Set rng = ws1.Range("A1:IV" & Rows.Count)

   With Application
       CalcMode = .Calculation
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
   End With

   ' Add a worksheet to copy the a unique list and add the CriteriaRange
   Set ws2 = Worksheets.Add

   With ws2
       'This example filters on the first column in the range
       'first we copy the Unique data from this column to ws2
       rng.Columns(1).AdvancedFilter _
               Action:=xlFilterCopy, _
               CopyToRange:=.Range("B1"), Unique:=True

       'Then give A1 the same value as B1 (header of column 1) in ws2
       .Range("A1").Value = .Range("B1").Value

       'loop through the unique list in ws2 and filter/copy to a new sheet
       Lrow = .Cells(Rows.Count, "B").End(xlUp).Row
       For Each cell In .Range("B2:B" & Lrow)
           .Range("A2").Value = "=" & Chr(34) & "=" & cell.Value & Chr(34)
           Set WSNew = Sheets.Add
           On Error Resume Next
           WSNew.Name = cell.Value
           If Err.Number > 0 Then
               MsgBox "Change the name of : " & WSNew.Name & " manually"
               Err.Clear
           End If
           On Error GoTo 0
           rng.AdvancedFilter Action:=xlFilterCopy, _
                              CriteriaRange:=.Range("A1:A2"), _
                              CopyToRange:=WSNew.Range("A1"), _
                              Unique:=False

           WSNew.Range("C" & Rows.Count).End(xlUp).Offset(2, 0).FormulaR1C1 = "=SUM(R1C:R[-2]C)"

           WSNew.Columns.AutoFit
       Next

       'Delete the ws2 sheet
       On Error Resume Next
       Application.DisplayAlerts = False
       .Delete
       Application.DisplayAlerts = True
       On Error GoTo 0

   End With

   With Application
       .ScreenUpdating = True
       .Calculation = CalcMode
   End With
End Sub