Макрос "DeleteEmptyRows" - Мир MS Excel

Регистрация

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

= Мир MS Excel/Макрос "DeleteEmptyRows" - Мир MS Excel

Старая форма входа

Страница 1 из 2 1 2 »
Модератор форума: _Boroda_, китин

Макрос "DeleteEmptyRows" (Удаление всех пустых строк в таблице)

Макрос "DeleteEmptyRows"

Дата: Понедельник, 30.08.2010, 13:35 | Сообщение № 1

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Пустые строки в таблице мешают нормальной работе фильтра.
Макрос 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]

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

Дата: Пятница, 22.07.2011, 13:04 | Сообщение № 2

Группа: Гости

Спасибо большое, а как сделать всё тоже самое, только в выделенном диапазоне?

Ответить

Дата: Воскресенье, 30.09.2012, 23:22 | Сообщение № 3

Группа: Админы

Ранг: Участник клуба

Сообщений: 2793

Репутация: 1160 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

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.

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 01.10.2012, 11:33

Ответить

Дата: Понедельник, 01.10.2012, 09:47 | Сообщение № 4

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Почему-то у меня оказалась отключенной опция об оповещении о вопросах в этом топике... Случайно заглянул.
Увидел, что год назад был вопрос, на который, не дождавшись меня ( shy

shy

), ответил 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)

Почему-то у меня оказалась отключенной опция об оповещении о вопросах в этом топике... Случайно заглянул.
Увидел, что год назад был вопрос, на который, не дождавшись меня ( shy

shy

), ответил 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

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

СообщениеПочему-то у меня оказалась отключенной опция об оповещении о вопросах в этом топике... Случайно заглянул.
Увидел, что год назад был вопрос, на который, не дождавшись меня ( shy

shy

), ответил 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
Дата добавления - 01.10.2012 в 09:47

Дата: Понедельник, 01.10.2012, 09:55 | Сообщение № 5

Группа: Админы

Ранг: Участник клуба

Сообщений: 2793

Репутация: 1160 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

Quote (Alex_ST)

когда я решил протестировать работу макроса Gustav и для пробы выделил целиком столбец, то окончания работы макроса не дождался - пришлось "срубать" цикл но Ctrl+Break

Эх, у меня там косяк с номерами строк sad

sad

Ехал с ним в мыслях по дороге на работу, сейчас подправлю...

P.S. Подправил.

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 01.10.2012, 11:44

Ответить

Дата: Понедельник, 01.10.2012, 10:43 | Сообщение № 6

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Константин, весь лист перелопачивать смысла нет, да и формулы листов будут на каждый Delete тормозить, поэтому ограничение на UsedRange и отключение событий и пересчётов - это само собой разумеющиеся вещи.

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

Дата: Понедельник, 01.10.2012, 11:32 | Сообщение № 7

Группа: Админы

Ранг: Участник клуба

Сообщений: 2793

Репутация: 1160 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

Quote (Alex_ST)

весь лист перелопачивать смысла нет, да и формулы листов будут на каждый Delete тормозить, поэтому ограничение на UsedRange и отключение событий и пересчётов

Алексей, двумя руками согласен! Подправил у себя про UsedRange. Про отключение событий и пересчётов - не стал подправлять - имеющий глаза да увидит у Вас эти тонкости! smile

smile

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]

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 01.10.2012, 12:22

Ответить

Дата: Понедельник, 01.10.2012, 12:27 | Сообщение № 8

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Константин,
если не определять диапазон как Intersect(Selection.EntireRow, ActiveSheet.UsedRange), то будет разгруппировывать и потом при согласии пользователя рвать объединённые ячейки, "разрезаемые" границей Selection.
А если отказаться, то не сработает, остановится и вылетит в отладчик.
В конце-концов Ваш макрос выродится после доработок в то, что предложил я сегодня утром biggrin

biggrin

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

Дата: Понедельник, 01.10.2012, 12:56 | Сообщение № 9

Группа: Админы

Ранг: Участник клуба

Сообщений: 2793

Репутация: 1160 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

Не, Алексей, EntireRow мне в данном случае не интересен. Мне принципиально хочется именно локального выскребания пустых строк в пределах прямоугольного выделения.
Будем считать, что мой метод работает:
* при отсутствии группировки
* при отсутствии "рвущихся" объединенных ячеек (ниже и по бокам выделения)
* при наличии только одной области в выделении (Selection.Areas.Count = 1)
* при наличии ненулевого пересечения выделения и используемого диапазона таблицы (Not Intersect(Selection, ActiveSheet.UsedRange) Is Nothing)
* когда последняя строка выделения и используемого диапазона (UsedRange) не является последней строкой таблицы
И эти пункты являются объявленными ограничениями (restrictions) данного метода. И желающий да внедрит эти проверки (все или частично) в код самостоятельно smile

smile

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 01.10.2012, 13:05

Ответить

Дата: Понедельник, 01.10.2012, 13:24 | Сообщение № 10

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Да уж… Ограничений столько, что их список читать-то и то долго, а уж запомнить …
Может быть попробовать вместо Selection.EntireRow поиграть с CurrentRegion? Тогда сгруппированные ячейки на границах войдут в область обработки.
Правда, у Selection нет свойства CurrentRegion… sad

sad

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Понедельник, 01.10.2012, 13:25

Ответить

Дата: Понедельник, 01.10.2012, 13:49 | Сообщение № 11

Группа: Админы

Ранг: Участник клуба

Сообщений: 2793

Репутация: 1160 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

Quote (Alex_ST)

Может быть попробовать вместо Selection.EntireRow поиграть с CurrentRegion?

Ну, при случае можно попробовать...

Quote (Alex_ST)

Правда, у Selection нет свойства CurrentRegion

Отчего же? Selection.CurrentRegion вполне себе работает, например,
[vba]

Code

Selection.CurrentRegion.Select
или
? Selection.CurrentRegion.Address

[/vba]

МОИ: Ник, Tip box: 41001663842605

Сообщение отредактировал Gustav - Понедельник, 01.10.2012, 13:50

Ответить

Дата: Понедельник, 01.10.2012, 13:54 | Сообщение № 12

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Честно говоря, не проверял. Просто тупо вместо Intersect(Selection.EntireRow, ActiveSheet.UsedRange) написал Intersect(Selection.CurrentRegion, ActiveSheet.UsedRange)
Попробовал запустить. Вылетел в отладчик на этой строке. Разобраться не успел - на работу пришлось отвлечься. biggrin

biggrin

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

Дата: Понедельник, 01.10.2012, 18:46 | Сообщение № 13

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

вариация на тему
[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]
А вообще, довольно часто возникающая задача. Может, еще вариантов?

Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem - Вторник, 02.10.2012, 14:58

Ответить

Дата: Понедельник, 01.10.2012, 19:06 | Сообщение № 14

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

вот так, вроде, симпатичнее
[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

[/vba]

Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem - Вторник, 02.10.2012, 09:02

Ответить

Дата: Вторник, 02.10.2012, 08:25 | Сообщение № 15

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Quote (Gustav)

подумал, что по крайней мере с Calculation надо бы поделикатнее поступить (вдруг пользователь и так на мануале):

Может быть я и недостаточно хорошо знаю Excel, но я пока (начиная с освоения Excel-98 biggrin

biggrin

) ни разу не сталкивался с необходимостью отключать автоматический пересчёт. А от циклических ссылок и итераций я шарахаюсь как чёрт от ладана.
Но это, конечно, Ваше дело. И введение одной переменной для запоминания/восстановления заданного пользователем состояния код практически не усложняет и принципа действия не меняет.

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Вторник, 02.10.2012, 08:27

Ответить

Дата: Вторник, 02.10.2012, 09:13 | Сообщение № 16

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

nilem,
а что возвращает свойство .Text диапазона?
Что-то я его никогда так не использовал …
А в справке ничего не нашёл cry

cry

С уважением,
Алексей
MS Excel 2003 - the best!!!

Ответить

Дата: Вторник, 02.10.2012, 09:52 | Сообщение № 17

Группа: Авторы

Ранг: Старожил

Сообщений: 1613

Репутация: 563 ±

Замечаний: 0% ±

Excel 2013, 2016

Если все ячейки диапазона содержат одинаковые значения, то .Text возвращает это значение. Попробуйте в A1:D1 записать "asd", тогда
[vba]

Code

Sub tt()
If Range("A1:D1").Text = "asd" Then MsgBox "all cells are asd" Else MsgBox "all cells are not asd"
End Sub

[/vba]
Свойство только для чтения. Например, так не получится:
Range("A2:D2").Text = "asd"

Яндекс.Деньги 4100159601573

Сообщение отредактировал nilem - Вторник, 02.10.2012, 09:53

Ответить

Дата: Вторник, 02.10.2012, 09:58 | Сообщение № 18

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Спасибо, Николай.
Оказывается, не забыл, а не знал cry

cry

Интересно, что это свойство очень мало используется. Надо будет попытаться запомнить, ведь в справке-то нет ничего (или я просто слепой?).

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Вторник, 02.10.2012, 10:03

Ответить

Дата: Вторник, 02.10.2012, 10:27 | Сообщение № 19

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

Николай, подправьте ЗДЕСЬ
[vba]

Code

With Application
usrCalculation = .Calculation: .ScreenUpdating = False: .EnableEvents = False: .Calculation = usrCalculation
End With

[/vba]
на
[vba]

Code

With Application
usrCalculation = .Calculation: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With

[/vba]

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Вторник, 02.10.2012, 10:51

Ответить

Дата: Вторник, 02.10.2012, 10:51 | Сообщение № 20

Группа: Админы

Ранг: Участник клуба

Сообщений: 2793

Репутация: 1160 ±

Замечаний: ±

начинал с Excel 4.0, видел 2.1

A1: пусто
B1: =ЕСЛИ(СЕГОДНЯ()<0;"бла-бла";"")
С1: пусто
D1: =ПСТР("Некоторый текст";1000;1)
E1: =""

? Range("A1:E1").Text = vbNullString
True

sad

sad

? Application.CountA(Range("A1:E1"))
3

МОИ: Ник, Tip box: 41001663842605

Ответить

Макрос "DeleteEmptyRows" (Удаление всех пустых строк в таблице)

Страница 1 из 2
1
2
»

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