Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление строк по условию. Как ускорить макрос?
 
#1
25.01.2013 15:36:50
В листе около 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
25.01.2013 15:42:47
Самый быстрый способ - автофильтр.
There is no knowledge that is not power
 
 
 
#3
25.01.2013 15:50:43
в принципе ускорить можно.

а логика-то правильная?
лишнего макрос не удаляет?..

пс. .Interior.Color = 3
вы уверены, что в этом месте вам нужен именно Color, а не ColorIndex?
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#4
25.01.2013 16:00:09
Вы правы ColorIndex, просто не кооректно скопировал. Но скорость выполнения от этого не меняется..)
 
 
 
#5
25.01.2013 16:04:08
Как-то так...
There is no knowledge that is not power
 
 
 
#6
25.01.2013 16:33:51
Пока никак не получается реализовать Вашу идею в моем макросе:( Нельзя ли показать на моем варианте, как это работает?
 
 
 
#7
25.01.2013 16:36:17
Прикрепите файл.
There is no knowledge that is not power
 
 
 
#8
25.01.2013 17:10:25
Вот.
Только 2,5 тыс строк не помещается по размеру сюда..Пришлось подсократить.
 
 
 
#9
25.01.2013 17:17:38
Автофильтром не получится, так как диапазон должен быть связанным.
Например, если фильтр поставить в строке 2, то максимум, что он заберёт, это только третья строка.
There is no knowledge that is not power
 
 
 
#10
25.01.2013 17:47:07
Цитата
Johny пишет: Автофильтром не получится, так как диапазон должен быть связанным.
гм...  :oops:
а мы, случаем, не путаем "автофильтр" и "автоопределение диапазона для автофильтра"?
таки две большие разницы.  ;)
фрилансер Excel, VBA - контакты в профиле
"Совершенствоваться не обязательно. Выживание — дело добровольное." Э.Деминг
 
 
 
#11
25.01.2013 18:49:43
есть вот такой вариант
Код
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
Изменено: nilem - 25.01.2013 18:52:32 (опять неудача со спойлерами (пойду тренироваться :)))
 
 
 
#12
27.01.2013 15:14:26
Скорость 3-го макроса подходящая, только вот никак не получается его заставить удалять только строки, удовлетворяющие условию (с заданным цветом в 6-м столбце или с "0" в этом же столбще, как в моем примере). Возможно это потому, что я не до конца понимаю как он работает:(
 
 
 
#13
27.01.2013 15:49:38
Voh,
вот здесь:
Код
If .Item(i, 6).Interior.ColorIndex = 15 Or _
           .Item(i, 6).Value = 0

Item(i, 6) - это 6-й столбец. Если серая заливка (ColorIndex = 15) или значение 0 (Value = 0), то удаляем всю строку. У вас разве не так работает?
файлик на всякий случай
 
 
 
#14
27.01.2013 20:50:29
Автофильтр. В примере в серых ячейках пусто, поэтому отфильтровываются нули и пустые.
Код
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".
Изменено: Казанский - 27.01.2013 20:51:12
 
 
 
#15
31.01.2013 19:04:49
nilem, спасибо большое за макрос, разобрался, вроде удаляет теперь то, что нужно. Очень жаль, что он очень сильно редактирует лист: разъединяет ячейки, сбивает их границы..( Подумаю, как с этим справиться.
 
 
 
#16
31.01.2013 19:06:35
To "Казанский":
Извините, но очень медленно работает, не подойдет, к сожалению.
 
 
 
#17
31.01.2013 23:02:50
Думаю, нужно ещё и пересчёт на время удаления отключить. А может ещё и события - тогда зашевелится.
 
 
 
#18
31.01.2013 23:53:36
Цитата
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 сек.
Можно создать новый лист в исходной книге, а исходный лист удалить.
 
 
 
#19
01.02.2013 13:06:01
Цитата
Казанский пишет:
надо не удалять ненужные строки, а переносить на новый лист нужные
Это отличная идея, думаю впоследствии так и надо будет сделать, т.к. это проще и безопаснее.
Но эти таблицы с данными содержат большое количество всякой ерунды: группировку диапазонов, макросы, формулы в ячейках, заданные печатные области, ячейкам присвоены формулы и условное форматирование, разные стили текстов, цвета и т.д. Тогда придется переносить с учетом всего этого, т.е. создавать идентичную копию с точки зрения всего перечисленного...Скорей всего это будет сложнее, чем просто удалить все ненужное..
 
 
 
#20
01.02.2013 16:44:49
В моей практике автофильтр не всегда достачно быстр, особенно в очень массивных книгах по 30 и более мб в формате xlsb, содержащие заливки по цветам, примечания и т.д.

Можно попробовать получить данные о цвете ячеек в нужном столбце в массив, в нем найти необходимые значение, запомнить их и удалить все строки единовременно, предварительно отключив пересчет формул, обновления экрана и т.д.
Изменено: SkyShark - 01.02.2013 16:45:59
 
 
 
#21
02.02.2013 17:29:28
Всем привет! Давненько меня тут не было :) Решил заглянуть.... просматривал темы и разумеется больше всего привлекла внимание тема, где нужно что-то ускорить :) Сделал сравнительную характеристику всех методов, какие были приведены и добавил свои. Что получилось - смотрите  :) Проверку на цвет фона задействовать не было смысла... на сколько я понял, у автора вопроса она служит просто как визуальное разграничение данных.
При каждом нажатии на кнопку вначале копируются исходные данные, это время в результатах не учитывается.
 
 
 
#22
02.02.2013 17:32:44
На имя файла не обращайте внимание... то я ковырял макрофункцию ПОЛУЧИТЬ.ЯЧЕЙКУ с целью определения цвета фона. Но потом понял, что цвет фона можно не анализировать... а переименовать файл забыл :)
 
 
 
#23
02.02.2013 19:52:19
Да, так вот, предлагаю взглянуть на альтернативный вариант доступа к свойствам ячейки посредством функции ПОЛУЧИТЬ.ЯЧЕЙКУ(). Описание можно посмотреть тут: 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 - какая-то операция
 
 
 
#24
16.02.2013 16:52:59
ANik, благодарю за участие и помощь, Ваш макрос быстрый и интересный. В действительности гораздо быстрее работает поиск и копирование, нежели поиск и удаление, это правда.
Но я так и не смог добиться того, чтобы все приведенные примеры не изменяли структуру документа после копирования, для меня это очень важно, т.к. документ является формой отчетности и должен остаться без изменений. Я приложил файл с точной структурой этого документа, а не как раньше (похожий пример) и перечислил в нем все 3 варианта работы макросов из этой темы. В примере правда мало строк, чтобы уложиться в размер файла, но надо понимать, что их 2500++ шт.
В первом варианте (Voh), наверно нельзя загнать все в массив, т.к. придется менять весь код.., а остальные варианты сильно форматируют документ..(
Изменено: Voh - 19.02.2013 14:28:49
 
 
 
#25
20.02.2013 20:06:35
Есть еще вариант с автофильтром (пока без цветов, просто по точному значению "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

Может кто-то может оптимизировать по скорости такую конструкцию??
(Пример в предыдущем сообщении)
 
 
 
#26
01.02.2016 00:28:30
Тоже столкнулся с оччееень медленным удалением пустых строк в листе (у меня больше 4тыс и растут по дням :) ), перепробывал все, что есть в этой теме, кроме метода ANik с копированием на отдельный лист.... ничего не подошло по скорости, нашел на другом ресурсе - делюсь ЛИНКОМ  - работает как ракета!!!  
 
 
 
Страницы: 1
Наверх