Пустые строки в таблице мешают нормальной работе фильтра. Макрос DeleteEmptyRows позволяет удалить все пустые строки в таблице [vba]
Код
Sub DeleteEmptyRows() '--------------------------------------------------------------------------------------- ' Procedure : DeleteEmptyRows ' Author : The_Prist??? ' Topic_HEADER : Удаление всех пустых строк в таблице ' Topic_URL : http://www.planetaexcel.ru/tip.php?aid=31 ' Purpose : Удаление всех пустых строк в таблице '--------------------------------------------------------------------------------------- If MsgBox("Удалить все пустые строки на листе?", vbOKCancel Or vbQuestion Or vbDefaultButton1, "Удалить пустые строки?") = vbCancel Then Exit Sub Dim lLastRow As Long, i As Long lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count Application.ScreenUpdating = False For i = lLastRow To 1 Step -1 If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete Next Application.ScreenUpdating = True End Sub
[/vba]
Пустые строки в таблице мешают нормальной работе фильтра. Макрос DeleteEmptyRows позволяет удалить все пустые строки в таблице [vba]
Код
Sub DeleteEmptyRows() '--------------------------------------------------------------------------------------- ' Procedure : DeleteEmptyRows ' Author : The_Prist??? ' Topic_HEADER : Удаление всех пустых строк в таблице ' Topic_URL : http://www.planetaexcel.ru/tip.php?aid=31 ' Purpose : Удаление всех пустых строк в таблице '--------------------------------------------------------------------------------------- If MsgBox("Удалить все пустые строки на листе?", vbOKCancel Or vbQuestion Or vbDefaultButton1, "Удалить пустые строки?") = vbCancel Then Exit Sub Dim lLastRow As Long, i As Long lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count Application.ScreenUpdating = False For i = lLastRow To 1 Step -1 If Application.CountA(Rows(i)) = 0 Then Rows(i).Delete Next Application.ScreenUpdating = True End Sub
а как сделать всё тоже самое, только в выделенном диапазоне?
Удаление строк в пределах выделенного диапазона: [vba]
Code
Sub DeleteEmptyRowsInSelection() If MsgBox("Удалить все пустые строки в пределах выделенного диапазона?", vbOKCancel Or vbQuestion Or vbDefaultButton1, "Удалить пустые строки?") = vbCancel Then Exit Sub Dim i As Long Application.ScreenUpdating = False With Intersect(Selection, ActiveSheet.UsedRange) 'со справедливой подачи Alex_ST For i = .Rows.Count To 1 Step -1 If Application.CountA(.Rows(i)) = 0 Then .Rows(.Rows.Count + 1).Insert .Rows(i).Delete End If Next End With Application.ScreenUpdating = True End Sub
[/vba] Ячейки ниже диапазона по окончании работы макроса остаются на своих местах, которые они занимали до начала работы макроса. Если же надо, чтобы они "поднимались" по мере удаления строк внутри диапазона, следует закомментировать оператор Insert.
Quote (Гость)
а как сделать всё тоже самое, только в выделенном диапазоне?
Удаление строк в пределах выделенного диапазона: [vba]
Code
Sub DeleteEmptyRowsInSelection() If MsgBox("Удалить все пустые строки в пределах выделенного диапазона?", vbOKCancel Or vbQuestion Or vbDefaultButton1, "Удалить пустые строки?") = vbCancel Then Exit Sub Dim i As Long Application.ScreenUpdating = False With Intersect(Selection, ActiveSheet.UsedRange) 'со справедливой подачи Alex_ST For i = .Rows.Count To 1 Step -1 If Application.CountA(.Rows(i)) = 0 Then .Rows(.Rows.Count + 1).Insert .Rows(i).Delete End If Next End With Application.ScreenUpdating = True End Sub
[/vba] Ячейки ниже диапазона по окончании работы макроса остаются на своих местах, которые они занимали до начала работы макроса. Если же надо, чтобы они "поднимались" по мере удаления строк внутри диапазона, следует закомментировать оператор Insert.Gustav
Почему-то у меня оказалась отключенной опция об оповещении о вопросах в этом топике... Случайно заглянул. Увидел, что год назад был вопрос, на который, не дождавшись меня ( ), ответил Gustav. Посмотрел у себя и увидел, что макрос давно модернизирован так:[vba]
Code
Sub DeleteEmptyRows() '--------------------------------------------------------------------------------------- ' Procedure : DeleteEmptyRows ' Purpose : Удаление всех пустых строк в выделенном диапазоне '--------------------------------------------------------------------------------------- If MsgBox("Удалить все пустые строки в выделенном диапазоне?", vbYesNo + vbQuestion, "Удалить пустые строки?") = vbNo Then Exit Sub Dim lLastRow&, i& With Intersect(Selection.EntireRow, ActiveSheet.UsedRange) lLastRow = .Row - 1 + .Rows.Count With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For i = lLastRow To 1 Step -1 If Application.CountA(.Rows(i)) = 0 Then .Rows(i).Delete Next i With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End With End Sub
[/vba] В отличие от кода Константина, тут введено ограничение на действие только в UsedRange и на время работы в цикле отключаются события и пересчёт листа. Это существенно ускоряет работу (когда я решил протестировать работу макроса Gustav и для пробы выделил целиком столбец, то окончания работы макроса не дождался - пришлось "срубать" цикл но Ctrl+Break)
Почему-то у меня оказалась отключенной опция об оповещении о вопросах в этом топике... Случайно заглянул. Увидел, что год назад был вопрос, на который, не дождавшись меня ( ), ответил Gustav. Посмотрел у себя и увидел, что макрос давно модернизирован так:[vba]
Code
Sub DeleteEmptyRows() '--------------------------------------------------------------------------------------- ' Procedure : DeleteEmptyRows ' Purpose : Удаление всех пустых строк в выделенном диапазоне '--------------------------------------------------------------------------------------- If MsgBox("Удалить все пустые строки в выделенном диапазоне?", vbYesNo + vbQuestion, "Удалить пустые строки?") = vbNo Then Exit Sub Dim lLastRow&, i& With Intersect(Selection.EntireRow, ActiveSheet.UsedRange) lLastRow = .Row - 1 + .Rows.Count With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With For i = lLastRow To 1 Step -1 If Application.CountA(.Rows(i)) = 0 Then .Rows(i).Delete Next i With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic: End With End With End Sub
[/vba] В отличие от кода Константина, тут введено ограничение на действие только в UsedRange и на время работы в цикле отключаются события и пересчёт листа. Это существенно ускоряет работу (когда я решил протестировать работу макроса Gustav и для пробы выделил целиком столбец, то окончания работы макроса не дождался - пришлось "срубать" цикл но Ctrl+Break)Alex_ST
когда я решил протестировать работу макроса Gustav и для пробы выделил целиком столбец, то окончания работы макроса не дождался - пришлось "срубать" цикл но Ctrl+Break
Эх, у меня там косяк с номерами строк Ехал с ним в мыслях по дороге на работу, сейчас подправлю...
P.S. Подправил.
Quote (Alex_ST)
когда я решил протестировать работу макроса Gustav и для пробы выделил целиком столбец, то окончания работы макроса не дождался - пришлось "срубать" цикл но Ctrl+Break
Эх, у меня там косяк с номерами строк Ехал с ним в мыслях по дороге на работу, сейчас подправлю...
Константин, весь лист перелопачивать смысла нет, да и формулы листов будут на каждый Delete тормозить, поэтому ограничение на UsedRange и отключение событий и пересчётов - это само собой разумеющиеся вещи.
Константин, весь лист перелопачивать смысла нет, да и формулы листов будут на каждый Delete тормозить, поэтому ограничение на UsedRange и отключение событий и пересчётов - это само собой разумеющиеся вещи.Alex_ST
весь лист перелопачивать смысла нет, да и формулы листов будут на каждый Delete тормозить, поэтому ограничение на UsedRange и отключение событий и пересчётов
Алексей, двумя руками согласен! Подправил у себя про UsedRange. Про отключение событий и пересчётов - не стал подправлять - имеющий глаза да увидит у Вас эти тонкости!
P.S. Кстати, подумал, что по крайней мере с Calculation надо бы поделикатнее поступить (вдруг пользователь и так на мануале):
[vba]
Code
Dim usrCalculation As Long ... usrCalculation = Application.Calculation With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With ... ... With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = usrCalculation: End With
[/vba]
Quote (Alex_ST)
весь лист перелопачивать смысла нет, да и формулы листов будут на каждый Delete тормозить, поэтому ограничение на UsedRange и отключение событий и пересчётов
Алексей, двумя руками согласен! Подправил у себя про UsedRange. Про отключение событий и пересчётов - не стал подправлять - имеющий глаза да увидит у Вас эти тонкости!
P.S. Кстати, подумал, что по крайней мере с Calculation надо бы поделикатнее поступить (вдруг пользователь и так на мануале):
[vba]
Code
Dim usrCalculation As Long ... usrCalculation = Application.Calculation With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual: End With ... ... With Application: .ScreenUpdating = True: .EnableEvents = True: .Calculation = usrCalculation: End With
Константин, если не определять диапазон как Intersect(Selection.EntireRow, ActiveSheet.UsedRange), то будет разгруппировывать и потом при согласии пользователя рвать объединённые ячейки, "разрезаемые" границей Selection. А если отказаться, то не сработает, остановится и вылетит в отладчик. В конце-концов Ваш макрос выродится после доработок в то, что предложил я сегодня утром
Константин, если не определять диапазон как Intersect(Selection.EntireRow, ActiveSheet.UsedRange), то будет разгруппировывать и потом при согласии пользователя рвать объединённые ячейки, "разрезаемые" границей Selection. А если отказаться, то не сработает, остановится и вылетит в отладчик. В конце-концов Ваш макрос выродится после доработок в то, что предложил я сегодня утром Alex_ST
Не, Алексей, EntireRow мне в данном случае не интересен. Мне принципиально хочется именно локального выскребания пустых строк в пределах прямоугольного выделения. Будем считать, что мой метод работает: * при отсутствии группировки * при отсутствии "рвущихся" объединенных ячеек (ниже и по бокам выделения) * при наличии только одной области в выделении (Selection.Areas.Count = 1) * при наличии ненулевого пересечения выделения и используемого диапазона таблицы (Not Intersect(Selection, ActiveSheet.UsedRange) Is Nothing) * когда последняя строка выделения и используемого диапазона (UsedRange) не является последней строкой таблицы И эти пункты являются объявленными ограничениями (restrictions) данного метода. И желающий да внедрит эти проверки (все или частично) в код самостоятельно
Не, Алексей, EntireRow мне в данном случае не интересен. Мне принципиально хочется именно локального выскребания пустых строк в пределах прямоугольного выделения. Будем считать, что мой метод работает: * при отсутствии группировки * при отсутствии "рвущихся" объединенных ячеек (ниже и по бокам выделения) * при наличии только одной области в выделении (Selection.Areas.Count = 1) * при наличии ненулевого пересечения выделения и используемого диапазона таблицы (Not Intersect(Selection, ActiveSheet.UsedRange) Is Nothing) * когда последняя строка выделения и используемого диапазона (UsedRange) не является последней строкой таблицы И эти пункты являются объявленными ограничениями (restrictions) данного метода. И желающий да внедрит эти проверки (все или частично) в код самостоятельно Gustav
Да уж… Ограничений столько, что их список читать-то и то долго, а уж запомнить … Может быть попробовать вместо Selection.EntireRow поиграть с CurrentRegion? Тогда сгруппированные ячейки на границах войдут в область обработки. Правда, у Selection нет свойства CurrentRegion…
Да уж… Ограничений столько, что их список читать-то и то долго, а уж запомнить … Может быть попробовать вместо Selection.EntireRow поиграть с CurrentRegion? Тогда сгруппированные ячейки на границах войдут в область обработки. Правда, у Selection нет свойства CurrentRegion… Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Понедельник, 01.10.2012, 13:25
Честно говоря, не проверял. Просто тупо вместо Intersect(Selection.EntireRow, ActiveSheet.UsedRange) написал Intersect(Selection.CurrentRegion, ActiveSheet.UsedRange) Попробовал запустить. Вылетел в отладчик на этой строке. Разобраться не успел - на работу пришлось отвлечься.
Честно говоря, не проверял. Просто тупо вместо Intersect(Selection.EntireRow, ActiveSheet.UsedRange) написал Intersect(Selection.CurrentRegion, ActiveSheet.UsedRange) Попробовал запустить. Вылетел в отладчик на этой строке. Разобраться не успел - на работу пришлось отвлечься. Alex_ST
Sub DeleteEmptyRows2() If MsgBox("Удалить все пустые строки в выделенном диапазоне?", vbYesNo + vbQuestion, "Удалить пустые строки?") = vbNo Then Exit Sub Dim lLastRow As Long, i As Long, usrCalculation As Long With Application usrCalculation = .Calculation: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual End With With Intersect(Selection, ActiveSheet.UsedRange) lLastRow = .Row - 1 + .Rows.Count For i = lLastRow To 1 Step -1 If .Rows(i).Text = vbNullString Then .Rows(i).Delete Next i End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = usrCalculation End With End Sub
[/vba] А вообще, довольно часто возникающая задача. Может, еще вариантов?
вариация на тему [vba]
Code
Sub DeleteEmptyRows2() If MsgBox("Удалить все пустые строки в выделенном диапазоне?", vbYesNo + vbQuestion, "Удалить пустые строки?") = vbNo Then Exit Sub Dim lLastRow As Long, i As Long, usrCalculation As Long With Application usrCalculation = .Calculation: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual End With With Intersect(Selection, ActiveSheet.UsedRange) lLastRow = .Row - 1 + .Rows.Count For i = lLastRow To 1 Step -1 If .Rows(i).Text = vbNullString Then .Rows(i).Delete Next i End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = usrCalculation End With End Sub
[/vba] А вообще, довольно часто возникающая задача. Может, еще вариантов?nilem
Яндекс.Деньги 4100159601573
Сообщение отредактировал nilem - Вторник, 02.10.2012, 14:58
Sub DeleteEmptyRows3() Dim r As Range, rDel As Range On Error Resume Next With Intersect(Selection, ActiveSheet.UsedRange) Set rDel = .Item(1, 2) For Each r In .Columns(1).SpecialCells(xlCellTypeBlanks) With r.Resize(, .Columns.Count) If .Text = vbNullString Then Set rDel = Union(rDel, r) ' If .RowDifferences(r).Count = 0 Then Set rDel = Union(rDel, r) ' вариант End With Next r Intersect(.Columns(1), rDel).EntireRow.Delete End With End Sub
[/vba]
вот так, вроде, симпатичнее [vba]
Code
Sub DeleteEmptyRows3() Dim r As Range, rDel As Range On Error Resume Next With Intersect(Selection, ActiveSheet.UsedRange) Set rDel = .Item(1, 2) For Each r In .Columns(1).SpecialCells(xlCellTypeBlanks) With r.Resize(, .Columns.Count) If .Text = vbNullString Then Set rDel = Union(rDel, r) ' If .RowDifferences(r).Count = 0 Then Set rDel = Union(rDel, r) ' вариант End With Next r Intersect(.Columns(1), rDel).EntireRow.Delete End With End Sub
подумал, что по крайней мере с Calculation надо бы поделикатнее поступить (вдруг пользователь и так на мануале):
Может быть я и недостаточно хорошо знаю Excel, но я пока (начиная с освоения Excel-98 ) ни разу не сталкивался с необходимостью отключать автоматический пересчёт. А от циклических ссылок и итераций я шарахаюсь как чёрт от ладана. Но это, конечно, Ваше дело. И введение одной переменной для запоминания/восстановления заданного пользователем состояния код практически не усложняет и принципа действия не меняет.
Quote (Gustav)
подумал, что по крайней мере с Calculation надо бы поделикатнее поступить (вдруг пользователь и так на мануале):
Может быть я и недостаточно хорошо знаю Excel, но я пока (начиная с освоения Excel-98 ) ни разу не сталкивался с необходимостью отключать автоматический пересчёт. А от циклических ссылок и итераций я шарахаюсь как чёрт от ладана. Но это, конечно, Ваше дело. И введение одной переменной для запоминания/восстановления заданного пользователем состояния код практически не усложняет и принципа действия не меняет.Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Вторник, 02.10.2012, 08:27
Спасибо, Николай. Оказывается, не забыл, а не знал Интересно, что это свойство очень мало используется. Надо будет попытаться запомнить, ведь в справке-то нет ничего (или я просто слепой?).
Спасибо, Николай. Оказывается, не забыл, а не знал Интересно, что это свойство очень мало используется. Надо будет попытаться запомнить, ведь в справке-то нет ничего (или я просто слепой?).Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Вторник, 02.10.2012, 10:03
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
), ответил Gustav. 
Ехал с ним в мыслях по дороге на работу, сейчас подправлю... 
