For filter and delete I used this code

------------------------------------------------------------------

Dim rng As Range

Columns("I:I").Select
ActiveWorkbook.Names.Add name:="ListNames",
RefersToR1C1:="=Raport!C9"


Application.Goto Reference:="ListNames" 'Range for names

Selection.AutoFilter
Selection.AutoFilter Field:=1, _
Criteria1:="<1"

Set rng = ActiveSheet.AutoFilter.Range
Set rng = rng.Offset(1, 0).Resize(rng.Rows.Count - 1)
Set rng = rng.Columns(1).SpecialCells(xlVisible).EntireRow
rng.Delete
ActiveSheet.AutoFilterMode = False


Dim wsNew As Worksheet

Set wsNew = Worksheets.Add(After:=Worksheets(Worksheets.Count) )

wsNew.name = "Supergrupa"

Sheets("Raport").Select
ActiveSheet.UsedRange.Select
Selection.Copy
Sheets("Supergrupa").Select
ActiveSheet.Paste
Range("B:B,C:C,I:I,J:J,K:K").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select

Range("A1").Value = "Magazin"
Range("B1").Value = "Val1"
Range("C1").Value = "Val2"
Range("D1").Value = "Val3"
Range("E1").Value = "Supergr_id"
Range("F1").Value = "Supergr_den"

wsNew.Columns.AutoFit

Sheets("Raport").Select
Range("B:B,C:C,I:I").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft

------------------------------------------------------------------

Because I have 16000 rows and I use this subtotal twice it takes 2
minutes to complete.

I think that there are other ways to do this job faster, but 2 minutes
is not such a long time to wait.

Bye!