Пожалуйста, протестируйте следующий код. Он также сортирует полученный диапазон после фильтрации. Если нет необходимости, вы можете прокомментировать эту часть кода. Я использую массив для копирования содержимого без использования большого количества ресурсов (в случае большого диапазона). Если вам также необходимо скопировать формат диапазона, вы / мы можем использовать Копировать - Вставить:
Sub testFilterCopyNewSheet()
Dim sh As Worksheet, rng As Range, cnt As Long, newSh As Worksheet
Set sh = ActiveSheet
If sh.AutoFilterMode Then sh.Cells.AutoFilter
Set rng = sh.Cells(1, 1).CurrentRegion
rng.AutoFilter field:=33, Criteria1:= _
">=-.09", Operator:=xlAnd, Criteria2:="<=.01"
cnt = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row:
If cnt > 3 Then
sh.Range("A2", ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
End If
If sh.AutoFilterMode Then sh.Cells.AutoFilter
Set rng = sh.Cells(1, 1).CurrentRegion
rng.Sort key1:=sh.Cells(1, 33), order1:=xlAscending, Header:=xlYes
Set newSh = Worksheets.aDD(After:=Worksheets(Worksheets.count))
Dim arrSh As Variant
arrSh = sh.Range("A1").CurrentRegion.value
newSh.Range("A1").Resize(UBound(arrSh, 1), UBound(arrSh, 2)).value = arrSh
End Sub
Пожалуйста, подтвердите, что он делает то, что вам нужно. Протестировано на десятой части строк.
Отредактировано: обновленная версия, способная работать на огромном диапазоне, имеющем listObject (фильтр удаляется другим способом) ...
Пожалуйста проверьте следующий код:
Sub testFilterCopyNewSheet()
Dim sh As Worksheet, rng As Range, cnt As Long, newSh As Worksheet
Set sh = ActiveSheet
sh.ListObjects(1).Range.AutoFilter
Set rng = sh.Cells(1, 1).CurrentRegion
rng.Sort key1:=sh.Cells(1, 33), order1:=xlAscending, Header:=xlYes
rng.AutoFilter field:=33, Criteria1:= _
">=-0.09", Operator:=xlAnd, Criteria2:="<=0.01"
cnt = sh.Cells.SpecialCells(xlCellTypeLastCell).Row:
If cnt > 3 Then
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
sh.Range("A2", ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete
End If
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
sh.ListObjects(1).Range.AutoFilter
Set rng = sh.Cells(1, 1).CurrentRegion
Set newSh = Worksheets.aDD(After:=Worksheets(Worksheets.count))
Dim arrSh As Variant
arrSh = sh.Range("A1").CurrentRegion.value
With newSh.Range("A1").Resize(UBound(arrSh, 1), UBound(arrSh, 2))
.value = arrSh
.EntireColumn.AutoFit
End With
End Sub
Если вам нужно, чтобы данные в новом листе имели начальный порядок (сортировку), это также можно сделать. Я могу вставить еще один столбец после последнего существующего, увеличить там переменную, начиная с 1 до последней строки, и, наконец, применить фильтрацию полученного диапазона в этом столбце, а затем удалить его.
Если вам нужно поиграть с кодом , чтобы увидеть, какие критерии фильтрации являются лучшими, вновь созданному листу можно дать имя (скажем, «Результат»), и код предварительно будет его искать. Если он существует, он очищает свое содержимое, если нет, он создает новый ...