Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Удаление строки по заданному правилу - Мир MS Excel

Старая форма входа
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Удаление строки по заданному правилу (Макросы/Sub)
Удаление строки по заданному правилу
wwizard Дата: Понедельник, 02.11.2015, 02:58 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

Доброе время суток. Очередной раз прошу у форумчан помощи. Пересмотрел все что мог, но так и не нашел как сделать самому:

Есть очень большая таблица с данными, кусочек ее я приложил.
Руками ее всю просто не обработать, в ней более 70000 строк.

Требуется:
Колонка 8
Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце
.... либо
Оставить только те строки, где в ячейке 8 будет соответствие со вторым листом пятой колонке.

Что легче? Помогите пожалуйста с таким небольшим скриптом. Очень нужно.
К сообщению приложен файл: proba2.xlsm (13.5 Kb)


Сообщение отредактировал wwizard - Понедельник, 02.11.2015, 03:02
 
Ответить
СообщениеДоброе время суток. Очередной раз прошу у форумчан помощи. Пересмотрел все что мог, но так и не нашел как сделать самому:

Есть очень большая таблица с данными, кусочек ее я приложил.
Руками ее всю просто не обработать, в ней более 70000 строк.

Требуется:
Колонка 8
Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце
.... либо
Оставить только те строки, где в ячейке 8 будет соответствие со вторым листом пятой колонке.

Что легче? Помогите пожалуйста с таким небольшим скриптом. Очень нужно.

Автор - wwizard
Дата добавления - 02.11.2015 в 02:58
Roman777 Дата: Понедельник, 02.11.2015, 10:19 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 980
Репутация: 127 ±
Замечаний: 0% ±

Excel 2007, Excel 2013
wwizard, не очень ясно.
Колонка 8
Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце

Что значит соотвествует? равны?
Я глянул Ваш файл. Получается на листе 1 строк "поплавки" 11 шт. а на листе2 в первой колонке всего 6 таких наименований, причём строки совершенно разные.
Не ясно тут, надо удалить с листа1 все строки, содержащие "поплавки" в 8 столбце, или только те строки, которые будут на соотвествующей строке на листе 2 содержать "поплавки"?


Много чего не знаю!!!!
 
Ответить
Сообщениеwwizard, не очень ясно.
Колонка 8
Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце

Что значит соотвествует? равны?
Я глянул Ваш файл. Получается на листе 1 строк "поплавки" 11 шт. а на листе2 в первой колонке всего 6 таких наименований, причём строки совершенно разные.
Не ясно тут, надо удалить с листа1 все строки, содержащие "поплавки" в 8 столбце, или только те строки, которые будут на соотвествующей строке на листе 2 содержать "поплавки"?

Автор - Roman777
Дата добавления - 02.11.2015 в 10:19
Manyasha Дата: Понедельник, 02.11.2015, 10:31 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
wwizard, так нужно?
[vba]
Код
Sub tt()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim cell, arrSh2
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare
        For Each cell In Range(sh2.Cells(1, 1), sh2.Cells(sh2.Rows.Count, 1).End(xlUp)).Value
           If cell <> "" Then .Item(cell) = .Item(cell) + 1
        Next
        If .Count Then arrSh2 = .keys
    End With
    With sh1
        For i = .Cells(.Rows.Count, 8).End(xlUp).Row To 2 Step -1
            For j = 0 To UBound(arrSh2)
             If .Cells(i, 8) = arrSh2(j) Then .Cells(i, 8).EntireRow.Delete
        Next j, i
    End With
End Sub
[/vba]
Работает для случая
удалить с листа1 все строки, содержащие "поплавки" в 8 столбце
К сообщению приложен файл: proba-1.xlsm (21.2 Kb)


ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеwwizard, так нужно?
[vba]
Код
Sub tt()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim cell, arrSh2
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare
        For Each cell In Range(sh2.Cells(1, 1), sh2.Cells(sh2.Rows.Count, 1).End(xlUp)).Value
           If cell <> "" Then .Item(cell) = .Item(cell) + 1
        Next
        If .Count Then arrSh2 = .keys
    End With
    With sh1
        For i = .Cells(.Rows.Count, 8).End(xlUp).Row To 2 Step -1
            For j = 0 To UBound(arrSh2)
             If .Cells(i, 8) = arrSh2(j) Then .Cells(i, 8).EntireRow.Delete
        Next j, i
    End With
End Sub
[/vba]
Работает для случая
удалить с листа1 все строки, содержащие "поплавки" в 8 столбце

Автор - Manyasha
Дата добавления - 02.11.2015 в 10:31
Wasilich Дата: Понедельник, 02.11.2015, 11:16 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
Ну и мой примерчик с использованием формулы ВПР в столбце "V" на основании которой строка удаляется.
К сообщению приложен файл: wwizard.xls (47.0 Kb)


Сообщение отредактировал Wasilic - Понедельник, 02.11.2015, 11:50
 
Ответить
СообщениеНу и мой примерчик с использованием формулы ВПР в столбце "V" на основании которой строка удаляется.

Автор - Wasilich
Дата добавления - 02.11.2015 в 11:16
wwizard Дата: Понедельник, 02.11.2015, 17:49 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

А что значит эта 1 в столбце V - я без 1ки нажимаю, удалить - тоже все удаляется
 
Ответить
СообщениеА что значит эта 1 в столбце V - я без 1ки нажимаю, удалить - тоже все удаляется

Автор - wwizard
Дата добавления - 02.11.2015 в 17:49
wwizard Дата: Понедельник, 02.11.2015, 18:09 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

http://prntscr.com/8y6nh6 - такую ошибку пишет. Соеденил два скрипта на один лист.
Второй скрипт "tt" - не запускается, пишет ош - 400
К сообщению приложен файл: 0795674.xlsm (21.4 Kb)
 
Ответить
Сообщениеhttp://prntscr.com/8y6nh6 - такую ошибку пишет. Соеденил два скрипта на один лист.
Второй скрипт "tt" - не запускается, пишет ош - 400

Автор - wwizard
Дата добавления - 02.11.2015 в 18:09
Manyasha Дата: Понедельник, 02.11.2015, 18:20 | Сообщение № 7
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
wwizard,
без 1ки нажимаю, удалить - тоже все удаляется

это критерий, по которому удаляются строки, смотрите код, он там прописывается:
[vba]
Код
Cells(i, 22).FormulaLocal = "=ЕСЛИ(ЕОШИБКА(ВПР(H" & i & ";'Лист2'!A$1:A$" & r2 & ";1;0))=ЛОЖЬ;1;"""")"
[/vba]
поэтому работает, даже, если Вы формулу удалите.

"tt" - не запускается

Вставьте в обычный модуль, а не в модуль листа, либо укажите лист, с которого диапазон считывать:
[vba]
Код
For Each cell In sh2.Range(sh2.Cells(1, 1), sh2.Cells(sh2.Rows.Count, 1).End(xlUp)).Value
[/vba]


ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеwwizard,
без 1ки нажимаю, удалить - тоже все удаляется

это критерий, по которому удаляются строки, смотрите код, он там прописывается:
[vba]
Код
Cells(i, 22).FormulaLocal = "=ЕСЛИ(ЕОШИБКА(ВПР(H" & i & ";'Лист2'!A$1:A$" & r2 & ";1;0))=ЛОЖЬ;1;"""")"
[/vba]
поэтому работает, даже, если Вы формулу удалите.

"tt" - не запускается

Вставьте в обычный модуль, а не в модуль листа, либо укажите лист, с которого диапазон считывать:
[vba]
Код
For Each cell In sh2.Range(sh2.Cells(1, 1), sh2.Cells(sh2.Rows.Count, 1).End(xlUp)).Value
[/vba]

Автор - Manyasha
Дата добавления - 02.11.2015 в 18:20
Wasilich Дата: Понедельник, 02.11.2015, 19:12 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 1232
Репутация: 326 ±
Замечаний: 0% ±

2003
А что значит эта 1 в столбце V - я без 1ки нажимаю, удалить - тоже все удаляется
1-ки в столбце остались только потому, что я проверял правильность работы формулы и не стер их. Но это и не важно.
Макрос снизу вверх в столбце 22 ("V") вставляет формулу ВПР,
[vba]
Код
Cells(i, 22).FormulaLocal = "=ЕСЛИ(ЕОШИБКА(ВПР(H" & i & ";'Лист2'!A$1:A$" & r2 & ";1;0))=ЛОЖЬ;1;"""")"
[/vba]которая проверяет есть ли в списке "Лист2" такое же наименование. Если есть, прописывает в столбце 22 ("V") 1-цу, а следующая строка макроса
[vba]
Код
If Cells(i, 22) = 1 Then Rows(i).Delete
[/vba]проверяет, если прописалась 1-ца, удаляет эту строку. Все это происходит в процессе одного цикла. В дальнейшем эти формулы ничего не значат. А при следующем запуске макроса, столбец "V" строкой кода
[vba]
Код
Range("V2:V" & r1).ClearContents
[/vba]очищается и формулы пишутся заново. Так что, столбец в макросе можно поменять на любой по своему усмотрению. Он просто вспомогательный. Ну и "Лист2" в формуле, так же можно заменить на присвоенное ему имя. Надеюсь разжевал? :)


Сообщение отредактировал Wasilic - Понедельник, 02.11.2015, 19:18
 
Ответить
Сообщение
А что значит эта 1 в столбце V - я без 1ки нажимаю, удалить - тоже все удаляется
1-ки в столбце остались только потому, что я проверял правильность работы формулы и не стер их. Но это и не важно.
Макрос снизу вверх в столбце 22 ("V") вставляет формулу ВПР,
[vba]
Код
Cells(i, 22).FormulaLocal = "=ЕСЛИ(ЕОШИБКА(ВПР(H" & i & ";'Лист2'!A$1:A$" & r2 & ";1;0))=ЛОЖЬ;1;"""")"
[/vba]которая проверяет есть ли в списке "Лист2" такое же наименование. Если есть, прописывает в столбце 22 ("V") 1-цу, а следующая строка макроса
[vba]
Код
If Cells(i, 22) = 1 Then Rows(i).Delete
[/vba]проверяет, если прописалась 1-ца, удаляет эту строку. Все это происходит в процессе одного цикла. В дальнейшем эти формулы ничего не значат. А при следующем запуске макроса, столбец "V" строкой кода
[vba]
Код
Range("V2:V" & r1).ClearContents
[/vba]очищается и формулы пишутся заново. Так что, столбец в макросе можно поменять на любой по своему усмотрению. Он просто вспомогательный. Ну и "Лист2" в формуле, так же можно заменить на присвоенное ему имя. Надеюсь разжевал? :)

Автор - Wasilich
Дата добавления - 02.11.2015 в 19:12
wwizard Дата: Воскресенье, 08.11.2015, 15:29 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

ие "поплавки" в 8 столбце


Его както убыстрить можно? Прайс на 70000 строк, удаление происходит почти сутки.
 
Ответить
Сообщение
ие "поплавки" в 8 столбце


Его както убыстрить можно? Прайс на 70000 строк, удаление происходит почти сутки.

Автор - wwizard
Дата добавления - 08.11.2015 в 15:29
_Boroda_ Дата: Воскресенье, 08.11.2015, 18:25 | Сообщение № 10
Группа: Модераторы
Ранг: Местный житель
Сообщений: 16666
Репутация: 6478 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Прайс на 70000 строк, удаление происходит почти сутки.

На основе макроса Wasilic, вот этот макрос отрабатывал 75000 строк минут 10-12 (точно не засекал)
[vba]
Код
Sub WWW()
    Dim r1&, r2&, i&
    Application.ScreenUpdating = False
    cal_ = Application.Calculation
    Application.Calculation = xlCalculationManual
    r1 = Range("H" & Rows.Count).End(xlUp).Row
    r2 = Sheets("Лист2").Range("A" & Rows.Count).End(xlUp).Row
    For i = r1 To 2 Step -1
        If i Mod 100 = 0 Then DoEvents
        On Error Resume Next
        n_ = WorksheetFunction.Match(Range("H" & i), Sheets("Лист2").Range("A1:A" & r2), 0)
        hhh = Err.Number
        If Err.Number = 0 Then Rows(i).Delete
        On Error GoTo 0
    Next
    Application.Calculation = cal_
    Application.ScreenUpdating = True
End Sub
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
Прайс на 70000 строк, удаление происходит почти сутки.

На основе макроса Wasilic, вот этот макрос отрабатывал 75000 строк минут 10-12 (точно не засекал)
[vba]
Код
Sub WWW()
    Dim r1&, r2&, i&
    Application.ScreenUpdating = False
    cal_ = Application.Calculation
    Application.Calculation = xlCalculationManual
    r1 = Range("H" & Rows.Count).End(xlUp).Row
    r2 = Sheets("Лист2").Range("A" & Rows.Count).End(xlUp).Row
    For i = r1 To 2 Step -1
        If i Mod 100 = 0 Then DoEvents
        On Error Resume Next
        n_ = WorksheetFunction.Match(Range("H" & i), Sheets("Лист2").Range("A1:A" & r2), 0)
        hhh = Err.Number
        If Err.Number = 0 Then Rows(i).Delete
        On Error GoTo 0
    Next
    Application.Calculation = cal_
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 08.11.2015 в 18:25
SLAVICK Дата: Понедельник, 09.11.2015, 13:06 | Сообщение № 11
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
Мой макрос на 100 000 отработал меньше чем за минуту: ;)

Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу :D
К сообщению приложен файл: 0795674-1-.xlsm (22.4 Kb)


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICK - Понедельник, 09.11.2015, 13:07
 
Ответить
СообщениеМой макрос на 100 000 отработал меньше чем за минуту: ;)

Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу :D

Автор - SLAVICK
Дата добавления - 09.11.2015 в 13:06
wwizard Дата: Понедельник, 09.11.2015, 17:11 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

На основе макроса Wasilic, вот этот макрос отрабатывал 75000 строк минут 10-12 (точно не засекал)

Он удалил все, мгновенно, оставив только первую строку. А весь прайс исчез
 
Ответить
Сообщение
На основе макроса Wasilic, вот этот макрос отрабатывал 75000 строк минут 10-12 (точно не засекал)

Он удалил все, мгновенно, оставив только первую строку. А весь прайс исчез

Автор - wwizard
Дата добавления - 09.11.2015 в 17:11
wwizard Дата: Понедельник, 09.11.2015, 17:12 | Сообщение № 13
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

Мой макрос на 100 000 отработал меньше чем за минуту:

А как удалить саму кнопку Кнопка 1 - физически, или как ее передвинуть в другое место?
 
Ответить
Сообщение
Мой макрос на 100 000 отработал меньше чем за минуту:

А как удалить саму кнопку Кнопка 1 - физически, или как ее передвинуть в другое место?

Автор - wwizard
Дата добавления - 09.11.2015 в 17:12
SLAVICK Дата: Понедельник, 09.11.2015, 17:20 | Сообщение № 14
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
А как удалить саму кнопку Кнопка 1 - физически, или как ее передвинуть в другое место?

Можно удалить - тогда запускайте макрос из списка макросов
Можно подвинуть - правой кнопкой мыши клацните - а потом тащите куда нужно :D


Иногда все проще чем кажется с первого взгляда.
 
Ответить
Сообщение
А как удалить саму кнопку Кнопка 1 - физически, или как ее передвинуть в другое место?

Можно удалить - тогда запускайте макрос из списка макросов
Можно подвинуть - правой кнопкой мыши клацните - а потом тащите куда нужно :D

Автор - SLAVICK
Дата добавления - 09.11.2015 в 17:20
wwizard Дата: Понедельник, 09.11.2015, 17:43 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

А как создать? кнопку новую? (прошу простить если вопрос глупый)
[moder]Не надо задавать вопросы про кнопки (а также отвечать на них) в теме про удаление строк[/moder]


Сообщение отредактировал Pelena - Понедельник, 09.11.2015, 17:58
 
Ответить
СообщениеА как создать? кнопку новую? (прошу простить если вопрос глупый)
[moder]Не надо задавать вопросы про кнопки (а также отвечать на них) в теме про удаление строк[/moder]

Автор - wwizard
Дата добавления - 09.11.2015 в 17:43
SLAVICK Дата: Понедельник, 09.11.2015, 17:53 | Сообщение № 16
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
Пользуйтесь поиском - Гугл знает :D


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICK - Понедельник, 09.11.2015, 17:53
 
Ответить
СообщениеПользуйтесь поиском - Гугл знает :D

Автор - SLAVICK
Дата добавления - 09.11.2015 в 17:53
wwizard Дата: Понедельник, 09.11.2015, 18:09 | Сообщение № 17
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу


Не получилось перенести макрос сюда, так чтобы по значению с четвертого листа он создавал новый лист в самой книге, например номер 10, и копировал строки в него.
К сообщению приложен файл: Proba-new-kniga.xlsm (24.9 Kb)


Сообщение отредактировал wwizard - Понедельник, 09.11.2015, 18:10
 
Ответить
Сообщение
Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу


Не получилось перенести макрос сюда, так чтобы по значению с четвертого листа он создавал новый лист в самой книге, например номер 10, и копировал строки в него.

Автор - wwizard
Дата добавления - 09.11.2015 в 18:09
SLAVICK Дата: Понедельник, 09.11.2015, 18:17 | Сообщение № 18
Группа: Модераторы
Ранг: Старожил
Сообщений: 2290
Репутация: 766 ±
Замечаний: 0% ±

2019
Нужно всего навсего заменить одну строку:
[vba]
Код
Range("aK2:aK" & n).FormulaR1C1 = "=--ISERROR(MATCH(RC8,Лист4!R1C1:R10C1,0))"
[/vba]
на
[vba]
Код
Range("aK2:aK" & n).FormulaR1C1 = "=--ISERROR(MATCH(RC10,'Отд-прайс'!R1C1:R10C1,0))"
[/vba]

Прошу модераторов не злится за прошлый пост - ответ был не явный - а с намеком на правила
К сообщению приложен файл: 7775190-1-.xlsm (28.2 Kb)


Иногда все проще чем кажется с первого взгляда.

Сообщение отредактировал SLAVICK - Понедельник, 09.11.2015, 18:20
 
Ответить
СообщениеНужно всего навсего заменить одну строку:
[vba]
Код
Range("aK2:aK" & n).FormulaR1C1 = "=--ISERROR(MATCH(RC8,Лист4!R1C1:R10C1,0))"
[/vba]
на
[vba]
Код
Range("aK2:aK" & n).FormulaR1C1 = "=--ISERROR(MATCH(RC10,'Отд-прайс'!R1C1:R10C1,0))"
[/vba]

Прошу модераторов не злится за прошлый пост - ответ был не явный - а с намеком на правила

Автор - SLAVICK
Дата добавления - 09.11.2015 в 18:17
wwizard Дата: Вторник, 10.11.2015, 17:55 | Сообщение № 19
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 176
Репутация: 0 ±
Замечаний: 40% ±

Задавал тут вопрос на форуме, и мне помогли со скриптом. К сожалению я потерял ветку где это делал и не смог ее заного найти. Прошу модераторов НЕ удалять тему.

Условие:
1. Есть прайслист на 75000 строк, и около 15ти колонок.
а) В прайсе пять вложеных листов.
б) Сам прайс расположен на первом листе
в) В нем в столбце номер 8 идет список категорий.
2. Категори которые мне реально нужны, я скопировал ручками во второй вложенный лист.

Нужно:
Условие первое: Удалить всю строку первого листа, если в столбце номер 8 найдено совпадение с данными в столбце №1 второго листа.
... либо ...
Условие второе: Оставить только те строки, где в ячейке 8 будет соответствие со вторым листом пятой колонке.

Данный скрипт соответствует первому условию и меня полностью устраивает, за исключением того что происходит все крайне медленно. Т.е. 75 000 строк, обрабатываются до 6ти часов.

[vba]
Код
Sub в_Удаление_лишних_категорий()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim cell, arrSh2
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare
        For Each cell In Range(sh2.Cells(1, 1), sh2.Cells(sh2.Rows.Count, 1).End(xlUp)).Value
           If cell <> "" Then .Item(cell) = .Item(cell) + 1
        Next
        If .Count Then arrSh2 = .keys
    End With
    With sh1
        For i = .Cells(.Rows.Count, 8).End(xlUp).Row To 2 Step -1
            For j = 0 To UBound(arrSh2)
             If .Cells(i, 8) = arrSh2(j) Then .Cells(i, 8).EntireRow.Delete
        Next j, i
    End With
End Sub
[/vba]

Этот скрипт работает чуть быстрее, но всеравно "не фонтан"

[vba]
Код
Sub WWW()
    Dim r1&, r2&, i&
    Application.ScreenUpdating = False
    cal_ = Application.Calculation
    Application.Calculation = xlCalculationManual
    r1 = Range("H" & Rows.Count).End(xlUp).Row
    r2 = Sheets("Лист2").Range("A" & Rows.Count).End(xlUp).Row
    For i = r1 To 2 Step -1
        If i Mod 100 = 0 Then DoEvents
        On Error Resume Next
        n_ = WorksheetFunction.Match(Range("H" & i), Sheets("Лист2").Range("A1:A" & r2), 0)
        hhh = Err.Number
        If Err.Number = 0 Then Rows(i).Delete
        On Error GoTo 0
    Next
    Application.Calculation = cal_
    Application.ScreenUpdating = True
End Sub
[/vba]

Как можно увеличить скорость данной процедуры?
К сообщению приложен файл: PROBA-32.xlsm (23.4 Kb)


Сообщение отредактировал wwizard - Вторник, 10.11.2015, 17:57
 
Ответить
СообщениеЗадавал тут вопрос на форуме, и мне помогли со скриптом. К сожалению я потерял ветку где это делал и не смог ее заного найти. Прошу модераторов НЕ удалять тему.

Условие:
1. Есть прайслист на 75000 строк, и около 15ти колонок.
а) В прайсе пять вложеных листов.
б) Сам прайс расположен на первом листе
в) В нем в столбце номер 8 идет список категорий.
2. Категори которые мне реально нужны, я скопировал ручками во второй вложенный лист.

Нужно:
Условие первое: Удалить всю строку первого листа, если в столбце номер 8 найдено совпадение с данными в столбце №1 второго листа.
... либо ...
Условие второе: Оставить только те строки, где в ячейке 8 будет соответствие со вторым листом пятой колонке.

Данный скрипт соответствует первому условию и меня полностью устраивает, за исключением того что происходит все крайне медленно. Т.е. 75 000 строк, обрабатываются до 6ти часов.

[vba]
Код
Sub в_Удаление_лишних_категорий()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim cell, arrSh2
    Set sh1 = ThisWorkbook.Sheets(1)
    Set sh2 = ThisWorkbook.Sheets(2)
    With CreateObject("Scripting.Dictionary"): .CompareMode = vbTextCompare
        For Each cell In Range(sh2.Cells(1, 1), sh2.Cells(sh2.Rows.Count, 1).End(xlUp)).Value
           If cell <> "" Then .Item(cell) = .Item(cell) + 1
        Next
        If .Count Then arrSh2 = .keys
    End With
    With sh1
        For i = .Cells(.Rows.Count, 8).End(xlUp).Row To 2 Step -1
            For j = 0 To UBound(arrSh2)
             If .Cells(i, 8) = arrSh2(j) Then .Cells(i, 8).EntireRow.Delete
        Next j, i
    End With
End Sub
[/vba]

Этот скрипт работает чуть быстрее, но всеравно "не фонтан"

[vba]
Код
Sub WWW()
    Dim r1&, r2&, i&
    Application.ScreenUpdating = False
    cal_ = Application.Calculation
    Application.Calculation = xlCalculationManual
    r1 = Range("H" & Rows.Count).End(xlUp).Row
    r2 = Sheets("Лист2").Range("A" & Rows.Count).End(xlUp).Row
    For i = r1 To 2 Step -1
        If i Mod 100 = 0 Then DoEvents
        On Error Resume Next
        n_ = WorksheetFunction.Match(Range("H" & i), Sheets("Лист2").Range("A1:A" & r2), 0)
        hhh = Err.Number
        If Err.Number = 0 Then Rows(i).Delete
        On Error GoTo 0
    Next
    Application.Calculation = cal_
    Application.ScreenUpdating = True
End Sub
[/vba]

Как можно увеличить скорость данной процедуры?

Автор - wwizard
Дата добавления - 10.11.2015 в 17:55
Manyasha Дата: Вторник, 10.11.2015, 18:10 | Сообщение № 20
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
wwizard, вот Ваша прошлая тема: http://www.excelworld.ru/forum/10-19863-1
Макрос Ярослава пробовали применить? Что не устроило?
Прошу модераторов НЕ удалять тему
Объясните, чем эта тема отличается от предыдущей, или соединю ее с прошлой.
[moder]Объединила темы[/moder]


ЯД: 410013299366744 WM: R193491431804

Сообщение отредактировал Pelena - Вторник, 10.11.2015, 19:49
 
Ответить
Сообщениеwwizard, вот Ваша прошлая тема: http://www.excelworld.ru/forum/10-19863-1
Макрос Ярослава пробовали применить? Что не устроило?
Прошу модераторов НЕ удалять тему
Объясните, чем эта тема отличается от предыдущей, или соединю ее с прошлой.
[moder]Объединила темы[/moder]

Автор - Manyasha
Дата добавления - 10.11.2015 в 18:10
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Удаление строки по заданному правилу (Макросы/Sub)
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!