Range("D7:F" & 6 + UBound(arr)).Value = arr

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ArrRez()
Dim TmpArrRez()

If (Union(Target.Cells(1), Range("H6")).Address = Range("H6").Address) Then
'-------------------------------------------------
'-- Блок сортировки
Лист2.ListObjects("Реестр").Sort.SortFields.Clear
Лист2.ListObjects("Реестр").Sort.SortFields.Add _
Key:=Range("Реестр[Сумма]"), _
SortOn:=xlSortOnValues, _
Order:=xlDescending, _
DataOption:=xlSortNormal

[color=red]With Лист2.ListObjects("Реестр").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With[/color]
'-------------------------------------------------
'-- Задаем нужную сумму
summ = Range("H6").Value

'-- Копируем масив данных в память
[color=red]arr = Range("D7:F" & Range("F1048000").End(xlUp).Row).Value[/color]

'-- Очищаем правую таблицу
Range("K7:M" & Range("M7").End(xlDown).Row).ClearContents

ReDim TmpArrRez(LBound(arr, 2) To UBound(arr, 2), 1 To 1)

'-- Перебор данных в памяти
For i = LBound(arr) To UBound(arr)
[color=red]A = Val(arr(i, 3))[/color]
'-- Если очередное значение менше суммы и болше нуля переносим в таблицу
[color=red]If A <= summ And A > 0 Then[/color]
For j = LBound(arr, 2) To UBound(arr, 2)
'-- Сам перенос знрачений
TmpArrRez(j, UBound(TmpArrRez, 2)) = arr(i, j)
arr(i, j) = ""
Next j
ReDim Preserve TmpArrRez(LBound(arr, 2) To UBound(arr, 2), 1 To UBound(TmpArrRez, 2) + 1)
summ = summ - A
End If
If summ = 0 Then Exit For
Next i

'-- Транспонируем полученую таблицу
ReDim ArrRez(LBound(TmpArrRez, 2) To UBound(TmpArrRez, 2), LBound(TmpArrRez) To UBound(TmpArrRez))
For i = LBound(ArrRez) To UBound(ArrRez)
For j = LBound(arr, 2) To UBound(arr, 2)
ArrRez(i, j) = TmpArrRez(j, i)
Next j
Next i

'-- Вывод значений на лист
Range("K7:M" & 6 + UBound(ArrRez)).Value = ArrRez
Range("D7:F" & 6 + UBound(arr)).Value = arr
End If
End Sub