Sub Get_All_File_from_Folder()
    Dim sFolder As String, sFiles As String, arr, arr2, arr3, i As Long, n As Long, lr As Long, k As Long, COL As New Collection
    
    Dim wb As Workbook
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    Application.ScreenUpdating = False
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        Set wb = Application.Workbooks.Open(sFolder & sFiles)
        Erase arr2
        With Sheets(1)
        Columns(6).Delete
        Columns(6).Delete
        Columns(6).Delete
lr = .Cells(Rows.Count, 1).End(xlUp).Row
arr = .Range("A2:F" & lr)
For i = LBound(arr) To UBound(arr)
    On Error Resume Next
    COL.Add arr(i, 1) & "//" & arr(i, 2) & "//" & arr(i, 3) & "//" & arr(i, 4) & "//" & "?????", arr(i, 1) & "//" & arr(i, 2) & "//" & arr(i, 3) & "//" & arr(i, 4) & "//" & "?????" & "//"
Next i
ReDim arr2(1 To COL.Count, 1 To 6)
For i = 1 To COL.Count
    arr3 = Split(COL(i), "//")
    For n = LBound(arr3) To UBound(arr3)
        arr2(i, n + 1) = arr3(n)
    Next n
    arr2(i, 6) = Application.WorksheetFunction.SumIfs(.Columns(6), _
                 .Columns(1), arr3(0), _
                 .Columns(2), arr3(1), _
                 .Columns(3), arr3(2), _
                 .Columns(4), arr3(3))
Next i
End With
ActiveSheet.UsedRange.Offset(1).Clear
Sheets(1).Range("A2").Resize(UBound(arr2), 6) = arr2
Columns(5).Delete
Columns(3).Delete

        wb.Close True
        sFiles = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

Sub del30()
Dim objFS, objExcel, objWB, strPath, strExt, strList
strPath = "D:\vyborka\r1\r3\r2"
Set objFS = CreateObject("Scripting.FileSystemObject")
If objFS.FolderExists(strPath) Then
    Set objExcel = CreateObject("Excel.Application")
    For Each objItem In objFS.GetFolder(strPath).Files
        strExt = Left(LCase(objFS.GetExtensionName(objItem)), 3)
         If strExt = "xls" Or strExt = "xlsx" Or strExt = "xlsm" Then
            objExcel.Visible = False
            objExcel.DisplayAlerts = False
            Set objWB = objExcel.Workbooks.Open(objItem.Path)
            With objWB
                 .Worksheets(1).Rows("1:3").Delete
                 .Sheets("Условия запроса").Delete
                .Save
                .Close
            End With
            strList = strList & objItem.Name & vbNewLine
         End If
    Next
    objExcel.Quit: Set objExcel = Nothing
    If Len(strList) > 0 Then
        WScript.Echo "Обработанные файлы:" & vbNewLine & strList
    Else
        WScript.Echo "Ни одного подходящего файла не найдено."
    End If
Else
    WScript.Echo "Не найден путь " & UCase(strPath)
End If
Set objFS = Nothing
WScript.Quit 0
End Sub