Доброе время суток. Очередной раз прошу у форумчан помощи. Пересмотрел все что мог, но так и не нашел как сделать самому:
Есть очень большая таблица с данными, кусочек ее я приложил. Руками ее всю просто не обработать, в ней более 70000 строк.
Требуется: Колонка 8 Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце .... либо Оставить только те строки, где в ячейке 8 будет соответствие со вторым листом пятой колонке.
Что легче? Помогите пожалуйста с таким небольшим скриптом. Очень нужно.
Доброе время суток. Очередной раз прошу у форумчан помощи. Пересмотрел все что мог, но так и не нашел как сделать самому:
Есть очень большая таблица с данными, кусочек ее я приложил. Руками ее всю просто не обработать, в ней более 70000 строк.
Требуется: Колонка 8 Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце .... либо Оставить только те строки, где в ячейке 8 будет соответствие со вторым листом пятой колонке.
Что легче? Помогите пожалуйста с таким небольшим скриптом. Очень нужно.wwizard
Колонка 8 Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце
Что значит соотвествует? равны? Я глянул Ваш файл. Получается на листе 1 строк "поплавки" 11 шт. а на листе2 в первой колонке всего 6 таких наименований, причём строки совершенно разные. Не ясно тут, надо удалить с листа1 все строки, содержащие "поплавки" в 8 столбце, или только те строки, которые будут на соотвествующей строке на листе 2 содержать "поплавки"?
Колонка 8 Удалить всю строку первого листа, если ячейки в колонке 8 соответствуют наименованию в листе 2 в первом столбце
Что значит соотвествует? равны? Я глянул Ваш файл. Получается на листе 1 строк "поплавки" 11 шт. а на листе2 в первой колонке всего 6 таких наименований, причём строки совершенно разные. Не ясно тут, надо удалить с листа1 все строки, содержащие "поплавки" в 8 столбце, или только те строки, которые будут на соотвествующей строке на листе 2 содержать "поплавки"?Roman777
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
удалить с листа1 все строки, содержащие "поплавки" в 8 столбце
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
А что значит эта 1 в столбце V - я без 1ки нажимаю, удалить - тоже все удаляется
1-ки в столбце остались только потому, что я проверял правильность работы формулы и не стер их. Но это и не важно. Макрос снизу вверх в столбце 22 ("V") вставляет формулу ВПР, [vba]
[/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" в формуле, так же можно заменить на присвоенное ему имя. Надеюсь разжевал?
А что значит эта 1 в столбце V - я без 1ки нажимаю, удалить - тоже все удаляется
1-ки в столбце остались только потому, что я проверял правильность работы формулы и не стер их. Но это и не важно. Макрос снизу вверх в столбце 22 ("V") вставляет формулу ВПР, [vba]
[/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
Сообщение отредактировал Wasilic - Понедельник, 02.11.2015, 19:18
Прайс на 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
Прайс на 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
i = Application.WorksheetFunction.Sum(Range("Ak2:Ak" & n)) Debug.Print n - i + 1 Rows(n - i + 1 & ":" & n).Delete Shift:=xlUp Columns("aK:aK").Clear End Sub
[/vba]
Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу
Мой макрос на 100 000 отработал меньше чем за минуту:
[vba]
Код
Sub test() Dim n&, i& ActiveSheet.UsedRange n = Cells(1, 1).SpecialCells(xlLastCell).Row
i = Application.WorksheetFunction.Sum(Range("Ak2:Ak" & n)) Debug.Print n - i + 1 Rows(n - i + 1 & ":" & n).Delete Shift:=xlUp Columns("aK:aK").Clear End Sub
[/vba]
Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу SLAVICK
А как создать? кнопку новую? (прошу простить если вопрос глупый) [moder]Не надо задавать вопросы про кнопки (а также отвечать на них) в теме про удаление строк[/moder]
А как создать? кнопку новую? (прошу простить если вопрос глупый) [moder]Не надо задавать вопросы про кнопки (а также отвечать на них) в теме про удаление строк[/moder]wwizard
Сообщение отредактировал Pelena - Понедельник, 09.11.2015, 17:58
Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу
Не получилось перенести макрос сюда, так чтобы по значению с четвертого листа он создавал новый лист в самой книге, например номер 10, и копировал строки в него.
Фишка в том, что сортировка в сотни раз быстрее удаления строк - поэтому сначала отсортировал все что нужно, и потом за один раз удалил лишние строки снизу
Не получилось перенести макрос сюда, так чтобы по значению с четвертого листа он создавал новый лист в самой книге, например номер 10, и копировал строки в него.wwizard
Задавал тут вопрос на форуме, и мне помогли со скриптом. К сожалению я потерял ветку где это делал и не смог ее заного найти. Прошу модераторов НЕ удалять тему.
Условие: 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]
Как можно увеличить скорость данной процедуры?
Задавал тут вопрос на форуме, и мне помогли со скриптом. К сожалению я потерял ветку где это делал и не смог ее заного найти. Прошу модераторов НЕ удалять тему.
Условие: 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