Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Удаление строк по условию
 
#1
18.06.2019 11:29:58
Добрый день! Прошу помощи!
Есть макрос, который удаляет строки не попадающие под условия, но проблема в том, что они удаляются построчно, а это очень долго, т.к. строк, для анализа, может быть до 1 млн.
Перечитал несколько подобных тем, в т.ч. и по ссылке с другого ресурса, которую выкладывали здесь. Понимаю, что можно "прогнать" строки через цикл For Each...Next, но не могу понять как сделать это с моим кодом.
Макросы начал изучать не давно, поэтому прошу помочь!
Код
Sub Test()

Dim Картотека As Worksheet
Set Картотека = Worksheets("Картотека")

Dim FinalRow As Long
Dim dic1 As New Dictionary

FinalRow = Картотека.Cells(Rows.Count, 1).End(xlUp).Row

dic1.Add CStr("0059_Абонентский комплект"), 1
dic1.Add CStr("0060_АТС электронная"), 1
dic1.Add CStr("0065_Головная станция кабельного ТВ"), 1
dic1.Add CStr("0068_Домовой узел"), 1
dic1.Add CStr("0090_Магистральный узел"), 1
dic1.Add CStr("0105_Точка-многоточка"), 1
dic1.Add CStr("0123_Узел доступа телематических служб"), 1
dic1.Add CStr("0155_АТС аналоговая"), 1
dic1.Add CStr("0158_Оборудование РРС в составе АБК"), 1
dic1.Add CStr("0178_Оборудование БШПД в составе АБК"), 1
dic1.Add CStr("0271_Точка доступа частного сектора"), 1

For a = 2 To FinalRow
    If dic1.Exists(CStr(Картотека.Cells(a, 48))) = False Then
        Картотека.Rows(a).Delete Shift:=xlUp
        a = a - 1
        FinalRow = FinalRow - 1
        If FinalRow < a Then
        Exit For
        End If
    End If
Next a


End Sub
Изменено: Jordan07 - 18.06.2019 11:32:53
 
 
 
#2
18.06.2019 11:41:07
Добрый день. В принципе, алгоритм довольно шустрый, основная потеря времени, кмк, это при отрисовке изменений (удалении строк).
Поэтому предлагаю после объявлений переменных вставить инструкцию отключения обновления экрана, а в конце включения его обратно.
Типа:
Код
Dim dic1 As New Dictionary
Application.ScreenUpdating=False
'тут идет код...
Application.ScreenUpdating=True
End Sub
Кому решение нужно - тот пример и рисует.
 
 
 
#3
18.06.2019 11:47:42
Цитата
Пытливый написал:
Поэтому предлагаю после объявлений переменных вставить инструкцию отключения обновления экрана
Да, спасибо! На самом деле это у меня есть в коде, не указал, когда прикладывал в вопрос, извиняюсь) Но отрабатывает все равно долго, около 20 минут.

Хотелось бы попробовать, чтобы сначала выделял все не нужные строки, а потом сразу все удалял
 
 
 
#4
18.06.2019 11:55:15
Цитата
Jordan07 написал: может быть до 1 млн
Да, миллион строк лучше обрабатывать в массиве
Код
Sub Test()
Dim arrKey(), arr(), arrNew()
Dim lRow&, I&, J&, N&, iKey, iTemp
Dim myRng As Range
arrKey = Array("0059_Абонентский комплект", "0060_АТС электронная", "0065_Головная станция кабельного ТВ", _
                "0068_Домовой узел", "0090_Магистральный узел", "0105_Точка-многоточка", _
                "0123_Узел доступа телематических служб", "0155_АТС аналоговая", "0158_Оборудование РРС в составе АБК", _
                "0178_Оборудование БШПД в составе АБК", "0271_Точка доступа частного сектора")
With Worksheets("Картотека")
    Set myRng = .Range(.Cells(2, 1), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(2, .Columns.Count).End(xlToLeft).Column))
    arr = myRng.Value
End With
ReDim arrNew(1 To UBound(arr, 1), 1 To UBound(arr, 2))
With CreateObject("Scripting.Dictionary")
    For Each iKey In arrKey
        iTemp = .Item(iKey)
    Next
    For I = 1 To UBound(arr, 1)
        If .Exists(arr(I, 48)) Then
            N = N + 1
            For J = 1 To UBound(arr, 2)
                arrNew(N, J) = arr(I, J)
            Next
        End If
    Next
End With
Application.ScreenUpdating = False
myRng.ClearContents
Worksheets("Картотека").Range("A2").Resize(N, UBound(arrNew, 2)) = arrNew
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#5
18.06.2019 12:10:11
Вот это уже хорошо) за секунды отработался на 70 тыс. строк

Только, почему-то остаются пустые строки в таблице. Я так понимаю из-за ClearContents? - очищает данные? Мне можно все удалять

Попробовал заменить на .Delete и очищает все форматы
 
 
 
#6
18.06.2019 12:11:54
Да, очищаются только данные
Можно очищать всё (.Clear) и затем форматировать по новой. Это всяко будет быстрее чем построчное удаление
Изменено: Sanja - 18.06.2019 12:15:37
Согласие есть продукт при полном непротивлении сторон
 
 
 
#7
18.06.2019 12:36:48
Не совсем подходит, правда) Задача минимизировать действия с отчетом, и форматировать по новой как-то не очень)

Но все равно, огромное спасибо за помощь!

И может быть, можно как-то сделать, чтобы только удалялись строки? Как предлагали по ссылке http://excelvba.ru/code/ConditionalRowsDeleting

Я, к сожалению, не смог понять, как подставить свой массив (dic1) в этот код
 
 
 
#8
18.06.2019 12:49:09
Код
Sub Test()
Dim arrKey(), arr()
Dim lRow&, I&, iKey, iTemp
Dim myRng As Range, delRows As Range
arrKey = Array("0059_Абонентский комплект", "0060_АТС электронная", "0065_Головная станция кабельного ТВ", _
                "0068_Домовой узел", "0090_Магистральный узел", "0105_Точка-многоточка", _
                "0123_Узел доступа телематических служб", "0155_АТС аналоговая", "0158_Оборудование РРС в составе АБК", _
                "0178_Оборудование БШПД в составе АБК", "0271_Точка доступа частного сектора")
With Worksheets("Картотека")
    Set myRng = .Range(.Cells(2, 1), Cells(.Cells(Rows.Count, 1).End(xlUp).Row, .Cells(2, .Columns.Count).End(xlToLeft).Column))
    arr = myRng.Value
End With
ReDim arrNew(1 To UBound(arr, 1), 1 To UBound(arr, 2))
With CreateObject("Scripting.Dictionary")
    For Each iKey In arrKey
        iTemp = .Item(iKey)
    Next
    For I = 1 To UBound(arr, 1)
        If .Exists(arr(I, 48)) Then
            If delRows Is Nothing Then
                Set delRows = myRng.Rows(I)
            Else
                Set delRows = Union(delRows, myRng.Rows(I))
            End If
        End If
    Next
End With
Application.ScreenUpdating = False
If Not delRows Is Nothing Then delRows.Delete
Application.ScreenUpdating = True
End Sub
Согласие есть продукт при полном непротивлении сторон
 
 
 
#9
18.06.2019 12:58:00
Супер! Только удаляет то, что нужно оставить))

Строки с этими значениями, наоборот, должны остаться, остальное удалить
Код
arrKey = Array("0059_Абонентский комплект", "0060_АТС электронная", "0065_Головная станция кабельного ТВ", _
                "0068_Домовой узел", "0090_Магистральный узел", "0105_Точка-многоточка", _
                "0123_Узел доступа телематических служб", "0155_АТС аналоговая", "0158_Оборудование РРС в составе АБК", _
                "0178_Оборудование БШПД в составе АБК", "0271_Точка доступа частного сектора")
With Worksheets("Картотека")
 
 
 
#10
18.06.2019 13:01:46
.
Изменено: Sanja - 18.06.2019 13:02:22
Согласие есть продукт при полном непротивлении сторон
 
 
 
#11
18.06.2019 13:05:25
Цитата
Jordan07 написал: Строки с этими значениями, наоборот, должны остаться, остальное удалить
В смысле?!  8-0
Разве это не Ваш код?
Цитата
Jordan07 написал:
If dic1.Exists(CStr(Картотека.Cells(a, 48))) = False
      Then Картотека.Rows(a).Delete Shift:=xlUp
Согласие есть продукт при полном непротивлении сторон
 
 
 
#12
18.06.2019 13:08:06
Тогда так
Код
If Not .Exists(arr(I, 48)) Then
Согласие есть продукт при полном непротивлении сторон
 
 
 
#13
18.06.2019 13:14:19
Цитата
Sanja написал: В смысле?!   Разве это не Ваш код?
Мой, но стоит же =FALSE (ЛОЖЬ)
Цитата
Sanja написал: Тогда так
Вот теперь все как надо! Благодарю)

До такого, я сам, вряд ли бы, в скором времени догадался)
Изменено: Jordan07 - 18.06.2019 14:30:54
 
 
 
#14
18.06.2019 13:22:54
Цитата
Jordan07 написал: Мой, но стоит же =FALSE (ЛОЖЬ)
Точно! Мой недогляд, извиняюсь!
Согласие есть продукт при полном непротивлении сторон
 
 
 
#15
18.06.2019 13:24:51
Ничего страшного) Еще раз спасибо!
 
 
 
#16
19.06.2019 11:55:13
Добрый день!

Сегодня попробовали макрос на другом компе
На данном этапе
Цитата
Sanja написал:
arr = myRng.Value
возникла ошибка "Out of memory". Не хватает оперативной памяти, я так понимаю

Можно ли с этим что-то сделать в коде макроса? (добавление оперативки на комп - не вариант)
 
 
 
#17
19.06.2019 12:04:53
А что у Вас в переменной myRng на момент ошибки?
Покажите проблемный файл
Изменено: Sanja - 19.06.2019 12:06:21
Согласие есть продукт при полном непротивлении сторон
 
 
 
#18
19.06.2019 13:17:18
В переменной также указывается "Out of memory"
Файл приложить, думаю, не получится, т.к. он на 800к строк
 
 
 
#19
19.06.2019 14:31:27
Выложите в облако и дайте здесь ссылку
Согласие есть продукт при полном непротивлении сторон
 
 
 
#20
19.06.2019 14:45:02
У меня ограничен доступ в интернет СБ, поэтому облаком пользоваться не могу
Но на своем компе, у меня макрос отрабатывает без проблем на этом же файле
 
 
 
Страницы: 1
Наверх