В листе около 2,5 тыс. строк, можно ли ускорить этот макрос, ато он ищет строки с заданными условиями около 10 минут или вообще виснет комп..?(
Код
Sub DeleteRows()
LastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
For row = LastRow To 1 Step -1
On Error Resume Next
if ActiveSheet.Cells(row, 6).Interior.Color = 3 Then ActiveSheet.Rows(row).Delete
If Cells(row, 6).Value = "0" Then ActiveSheet.Rows(row).Delete
Next row
Application.ScreenUpdating = True
ActiveSheet.Calculate
End Sub
Автофильтром не получится, так как диапазон должен быть связанным. Например, если фильтр поставить в строке 2, то максимум, что он заберёт, это только третья строка.
Sub DeleteRows22()
Dim i&, rDel As Range
Set rDel = Range("A1")
For i = 3 To Cells(Rows.Count, 6).End(xlUp).Row
If Cells(i, 6).Interior.ColorIndex = 15 Or _
Cells(i, 6).Value = 0 Then Set rDel = Union(rDel, Cells(i, 6))
Next i
If rDel.Cells.Count > 1 Then Intersect(rDel, Columns(6)).EntireRow.Delete
End Sub
или такой (вроде побыстрее)
Код
Sub DeleteRows33()
Dim i&
On Error Resume Next
With Range("F3", Cells(Rows.Count, 6).End(xlUp))
For i = 1 To .Rows.Count
If .Item(i, 1).Interior.ColorIndex = 15 Or _
.Item(i, 1).Value = 0 Then .Item(i, 1) = "#N/A"
Next i
.SpecialCells(2, 16).EntireRow.Delete
End With
End Sub
кажется, хорошие подходы, но на 3000 строк работают почему-то медленно, поэтому вот "радикальный" вариант (но объединенные яч. придется разъединить)
Код
Sub DeleteRows44()
Dim i&, j&, x()
With Range("A2:H" & Cells(Rows.Count, 6).End(xlUp).Row)
.UnMerge
ReDim x(1 To .Rows.Count, 1 To 1): x(1, 1) = "temp"
For i = 1 To .Rows.Count
If .Item(i, 6).Interior.ColorIndex = 15 Or _
.Item(i, 6).Value = 0 Then x(i, 1) = 1: j = j + 1
Next i
.Columns(8).Value = x()
.Sort Key1:=.Cells(1, 8), Order1:=xlAscending, Header:=xlYes
.Resize(j).Offset(1).EntireRow.Delete
.Columns(8).ClearContents
End With
End Sub
Скорость 3-го макроса подходящая, только вот никак не получается его заставить удалять только строки, удовлетворяющие условию (с заданным цветом в 6-м столбце или с "0" в этом же столбще, как в моем примере). Возможно это потому, что я не до конца понимаю как он работает:(
If .Item(i, 6).Interior.ColorIndex = 15 Or _
.Item(i, 6).Value = 0
Item(i, 6) - это 6-й столбец. Если серая заливка (ColorIndex = 15) или значение 0 (Value = 0), то удаляем всю строку. У вас разве не так работает? файлик на всякий случай
Автофильтр. В примере в серых ячейках пусто, поэтому отфильтровываются нули и пустые.
Код
Sub bb()
ActiveSheet.AutoFilterMode = False
With Range("F2:F" & Cells(Rows.Count, "B").End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
ActiveSheet.AutoFilterMode = False
End Sub
Если все же надо отделить пустые от серых, можно сначала записать нули в серые, а потом отфильтровать по одному критерию "=0".
nilem, спасибо большое за макрос, разобрался, вроде удаляет теперь то, что нужно. Очень жаль, что он очень сильно редактирует лист: разъединяет ячейки, сбивает их границы..( Подумаю, как с этим справиться.
Voh пишет: Извините, но очень медленно работает, не подойдет, к сожалению.
1. "Размножил" данные из вашего файла на 2946 строк таким макросом
Код
Sub mult()
Dim i&
i = 25
Do While i < 2500
Range("3:" & i).Copy Cells(i + 1, 1)
i = i + i - 2
Loop
End Sub
Измерил время своего макроса - 21,3 сек (ноут P3-500, Win2k, Офис 2000). Чтобы было быстрее, надо не удалять ненужные строки, а переносить на новый лист нужные:
Код
Sub bb()
Dim ws1, ws2
Dim t!: t = Timer 'измерение времени - можно исключить
Set ws1 = ActiveSheet
ws1.AutoFilterMode = False
Range("F2:F" & Cells(Rows.Count, "B").End(xlUp).Row) _
.AutoFilter Field:=1, Criteria1:=">0"
Set ws2 = Workbooks.Add(xlWBATWorksheet).Sheets(1)
With ws1.UsedRange
.Copy ws2.Cells(1, 1)
'перенос ширины столбцов - необязательно
.Rows(2).Copy
ws2.Cells(2, 1).PasteSpecial 8 'xlPasteColumnWidths
'конец переноса ширины столбцов
End With
ws1.AutoFilterMode = False
Debug.Print Timer - t 'измерение времени - можно исключить
End Sub
У меня срабатывает за 1,4 сек. Можно создать новый лист в исходной книге, а исходный лист удалить.
Казанский пишет: надо не удалять ненужные строки, а переносить на новый лист нужные
Это отличная идея, думаю впоследствии так и надо будет сделать, т.к. это проще и безопаснее. Но эти таблицы с данными содержат большое количество всякой ерунды: группировку диапазонов, макросы, формулы в ячейках, заданные печатные области, ячейкам присвоены формулы и условное форматирование, разные стили текстов, цвета и т.д. Тогда придется переносить с учетом всего этого, т.е. создавать идентичную копию с точки зрения всего перечисленного...Скорей всего это будет сложнее, чем просто удалить все ненужное..
В моей практике автофильтр не всегда достачно быстр, особенно в очень массивных книгах по 30 и более мб в формате xlsb, содержащие заливки по цветам, примечания и т.д.
Можно попробовать получить данные о цвете ячеек в нужном столбце в массив, в нем найти необходимые значение, запомнить их и удалить все строки единовременно, предварительно отключив пересчет формул, обновления экрана и т.д.
Всем привет! Давненько меня тут не было Решил заглянуть.... просматривал темы и разумеется больше всего привлекла внимание тема, где нужно что-то ускорить Сделал сравнительную характеристику всех методов, какие были приведены и добавил свои. Что получилось - смотрите Проверку на цвет фона задействовать не было смысла... на сколько я понял, у автора вопроса она служит просто как визуальное разграничение данных. При каждом нажатии на кнопку вначале копируются исходные данные, это время в результатах не учитывается.
На имя файла не обращайте внимание... то я ковырял макрофункцию ПОЛУЧИТЬ.ЯЧЕЙКУ с целью определения цвета фона. Но потом понял, что цвет фона можно не анализировать... а переименовать файл забыл
Да, так вот, предлагаю взглянуть на альтернативный вариант доступа к свойствам ячейки посредством функции ПОЛУЧИТЬ.ЯЧЕЙКУ(). Описание можно посмотреть тут: http://www.excelworld.ru/publ/funcs/makrofuncs/get_cell/24-1-0-78 Тест показал: 1. Закинуть на лист столбец с вычислением этой функции, чтобы получить форматирование ячеек, будет в разы быстрее, чем перебирать все ячейки в цикле. 2. Доступ к значениям ячеек производится примерно в 2 раза быстрее, чем доступ к их форматированию. 3. Перебор по массиву в разы быстрее, чем перебор по ячейкам, поэтому при желании ускориться, необходимо диапазон закидывать в массив и работать уже по массиву. Применительно к этой теме, то вместо конструкций, типа IF .Item(i, 6).Value = 0 Then x(i, 1) = 1 или IF Cells(i, 6).Value = 0 Then .... нужно было закинуть все значения диапазона в массив и сравнивать уже по массиву: Arr = Rng.Value IF arr(i, 1) = 0 Then - какая-то операция
ANik, благодарю за участие и помощь, Ваш макрос быстрый и интересный. В действительности гораздо быстрее работает поиск и копирование, нежели поиск и удаление, это правда. Но я так и не смог добиться того, чтобы все приведенные примеры не изменяли структуру документа после копирования, для меня это очень важно, т.к. документ является формой отчетности и должен остаться без изменений. Я приложил файл с точной структурой этого документа, а не как раньше (похожий пример) и перечислил в нем все 3 варианта работы макросов из этой темы. В примере правда мало строк, чтобы уложиться в размер файла, но надо понимать, что их 2500++ шт. В первом варианте (Voh), наверно нельзя загнать все в массив, т.к. придется менять весь код.., а остальные варианты сильно форматируют документ..(
Есть еще вариант с автофильтром (пока без цветов, просто по точному значению "0"). Но он тоже с большим количеством строк очень медленно работает, около минуты ещет...(
Код
Sub macro()
Rows("22:22").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Range("a21:F21"), ActiveCell.SpecialCells(xlLastCell)).AutoFilter
Selection.AutoFilter field:=6, Criteria1:="=0,00"
Range(Range("a21:F21"), ActiveCell.SpecialCells(xlLastCell)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Может кто-то может оптимизировать по скорости такую конструкцию?? (Пример в предыдущем сообщении)
Тоже столкнулся с оччееень медленным удалением пустых строк в листе (у меня больше 4тыс и растут по дням ), перепробывал все, что есть в этой теме, кроме метода ANik с копированием на отдельный лист.... ничего не подошло по скорости, нашел на другом ресурсе - делюсь ЛИНКОМ - работает как ракета!!!