Sub ОЗУ2019ф6()
Dim Wb As Workbook
For Each Wb In Workbooks
MsgBox Wb.Name
Next
Dim arr(), lr As Long, i As Long

Application.ScreenUpdating = False

ActiveSheet.Copy After:=ActiveSheet
ActiveSheet.AutoFilterMode = False
Rows.Hidden = False

ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending
ActiveSheet.Sort.SortFields.Add Key:=Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending
ActiveSheet.Sort.SortFields.Add Key:=Columns("I"), SortOn:=xlSortOnValues, Order:=xlAscending
ActiveSheet.Sort.SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending
With ActiveSheet.Sort
.SetRange Columns("A:I").Rows("3:" & Rows.Count)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With

lr = Cells(Rows.Count, "A").End(xlUp).Row
arr() = Range("A1:I" & lr).Value
For i = UBound(arr) To 9 Step -1
If arr(i, 1) = arr(i - 1, 1) And arr(i, 7) = arr(i - 1, 7) And arr(i, 9) = arr(i - 1, 9) And arr(i, 3) = arr(i - 1, 3) Then
arr(i - 1, 4) = arr(i - 1, 4) & "," & arr(i, 4)
arr(i - 1, 5) = arr(i - 1, 5) + arr(i, 5)
arr(i, 1) = Empty
End If
Next i
Range("A1:I" & lr).Value = arr()

On Error Resume Next
Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

Application.ScreenUpdating = True

End Sub