Sub tt()
    Dim a(), i&, ii&, x&, t$, el, elel, sum_ As Double
    Dim shapka As Range, podval As Range, name As Range
    Set shapka = Sheets(4).Range("A1:X6")
    Set podval = Sheets(4).Range("A9:M16")
    
    Application.ScreenUpdating = False
    a = Sheets(1).[a1].CurrentRegion.Columns(1).Resize(, 25).Value
    With CreateObject("Scripting.Dictionary")
        .comparemode = 1
        For i = 1 To UBound(a)
            t = a(i, 1) & "_" & a(i, 8)
            If Not .exists(t) Then .Add t, New Collection
            .Item(t).Add i
        Next
        For Each el In .keys
            ReDim aa(1 To .Item(el).Count, 2 To 25)
            ii = 0: sum_ = 0
            For Each elel In .Item(el)
             ii = ii + 1
                For x = 2 To 25: aa(ii, x) = a(elel, x): Next
                If IsNumeric(aa(ii, 25)) Then sum_ = sum_ + aa(ii, 25)
            Next
            With Workbooks.Add(1)
            With .Sheets(1)
                shapka.Copy .Cells(1)
                .Cells(4, 1).Value = Format(Now, "от" + " " + "dd.mm.yyyy")
                .Cells(7, 2).Resize(UBound(aa, 1)).NumberFormat = "0"
                .Cells(7, 1).Resize(UBound(aa), 24) = aa
                .Cells(UBound(aa) + 7, 23) = "Всего"
                .Cells(UBound(aa) + 7, 24) = sum_
                Union(.Columns(2), .Columns(3), .Columns(6), .Columns(7)).EntireColumn.AutoFit
                podval.Copy .Cells(UBound(aa) + 8, 1)
                Intersect(ActiveSheet.UsedRange, Range(aa)).Select

                End With
                .SaveAs ThisWorkbook.Path & "\" & el & ".xlsx"
                .Close 0
            End With
        Next
    End With
    Application.ScreenUpdating = True
MsgBox "Выгрузка успешно выполнена"
End Sub