Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
удаление пустых строк в "умной таблице"
 
#1
01.09.2015 13:55:44
Доброго дня, всем жителям Планеты Эксель!
Помогите пож. подкорректировать код для удаления "пустых" и "нулевых" строк в умной таблице.

Т.к. пока (надеюсь) в VBA не очень силен и не могу написать все с нуля, собрал несколько макросов для решения своей задачи.
Но макрос "del" отказался работать. Сам код работает (когда массив данных), но как только из таблицы делаешь "умную" - сразу ругается с ошибкой "400". Видимо очень умная  :)
файл с примером в приложении.
сам код ниже

Может у кого то будет желание оптимизировать (подкорректировать), макросы которые нашел на форумах, а то чувствую все можно было сделать гораздо проще и при увеличении таблицы может подвисать файлик (особенно что касается формул на листе "фасоль".
Заранее всем спасибо за любую помощь
Код
' удаление пустых и нулевых значений
Sub del()
    Dim iRange As Range, iRangeDelete As Range, msg As Long
    For Each iRange In Range(Cells(3, "A"), Cells(Cells(Rows.Count, "A").End(xlUp).Row, "A"))
 
        If iRange.Value = "" Then
           iRange.Select
            Set iRangeDelete = Union(iRange, _
                 IIf(iRangeDelete Is Nothing, iRange, iRangeDelete))
        End If
        If iRange.Value = 0 Then
            iRange.Select
            Set iRangeDelete = Union(iRange, _
                   IIf(iRangeDelete Is Nothing, iRange, iRangeDelete))
        End If
Next_Each:
    Next
 
    If Not iRangeDelete Is Nothing Then
        iRangeDelete.EntireRow.Delete
    Else
        Exit Sub
    End If
End Sub
 
 
 
#2
01.09.2015 14:05:55
Почитайте справку про объект ListObject, про его свойства и методы.

Формула массива (ФМ) вводится Ctrl+Shift+Enter
Memento mori
 
 
 
#3
01.09.2015 15:00:42
igor_ber, удобно перебирать строки и собирать диапазон удаления из них, чтобы обойтись без Entirerow. Упростил проверку.
И лучше размещать процедуры в обычном модуле, а не модуле листа. Тогда надо дописать Activesheet.ListObjects(1).
Код
Sub del()
    Dim iRange As Range, iRangeDelete As Range, msg As Long
    For Each iRange In ListObjects(1).DataBodyRange.Rows

        'If iRange.Interior.ColorIndex = 36 Then
         '  GoTo Next_Each
        'End If
        If iRange.Cells(1).Value = Empty Then
'           iRange.Select
            Set iRangeDelete = Union(iRange, _
                 IIf(iRangeDelete Is Nothing, iRange, iRangeDelete))
        End If
'Next_Each:
    Next

    If Not iRangeDelete Is Nothing Then
        iRangeDelete.Delete
    Else
        Exit Sub
    End If
End Sub
 
 
 
#4
01.09.2015 15:14:40
igor_ber, можно без перебора, с помощью автофильтра. Вот макрос, полученный макрорекордером и "допиленный"
Код
Sub Макрос4()
    With ActiveSheet.ListObjects(1)
      .Range.AutoFilter
      .Range.AutoFilter Field:=1, Criteria1:="=0", Operator:=xlOr, Criteria2:="="
      Application.DisplayAlerts = False
      On Error Resume Next
      .DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
      Application.DisplayAlerts = True
      .Range.AutoFilter
    End With
End Sub
 
 
 
#5
01.09.2015 16:07:56
Казанский спасибо большое за Вашу помощь. Все замечания учел, все работает :)
 
 
 
#6
10.12.2024 03:43:51
Осмелюсь немного упростить код:
Код
Sub Макрос4()
    On Error Resume Next
    ActiveSheet.ListObjects(1).DataBodyRange.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub
 
 
 
Страницы: 1
Наверх