Удаление строк по условию

@Egor.V.A · Регистрация: 01.06.2012

Author24 — интернет-сервис помощи студентам

Народ, помогите ускорить процесс:

Visual Basic

For i = 10000 To 1 Step -1
    If Cells(i, 2) = "" Then
        Range(Cells(i, 1), Cells(i, 2)).Select
        Selection.EntireRow.Delete
    End If
Next i

Уж очень долго работает, а надо, чтоб меньше секунды тратилось времени, такое возможно?

@~~Апострофф~~ · 01.08.2014, 10:37

1.

Visual Basic

For i = 10000 To 1 Step -1
    If Cells(i, 2) = "" Then
        'Range(Cells(i, 1), Cells(i, 2)).Select
        Cells(i, 2).EntireRow.Delete
    End If
Next i

2. Ищите ScreenUpdating и прочие фишки для ускорения работы кода - примеров на форуме 100500...

@snipe · 01.08.2014, 10:43

такое возможно

Добавлено через 3 минуты
1.напишите название столбцов
2.поставьте автофильтр
3.включите рекордер записи макроса
4. отфильтруйте записи
5. удалите ненужные записи
6. отключите рекордер записи макроса
7. нажмите alt+f11
8. посмотрите что написал сам Excel

думаю вы приятно удивитесь

@~~Апострофф~~ · 01.08.2014, 10:57

Visual Basic

sub Primer()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
For i = 10000 To 1 Step -1
    If Cells(i, 2) = "" Then
        'Range(Cells(i, 1), Cells(i, 2)).Select
        Cells(i, 2).EntireRow.Delete
    End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
End Sub

Не влияющие на скорость Вашего макроса пары переключателей можно удалить.

@Egor.V.A · 04.08.2014, 16:07 **[ТС]**

Visual Basic

sub Primer()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayStatusBar = False
Application.DisplayAlerts = False
For i = 10000 To 1 Step -1
* * If Cells(i, 2) = "" Then
* * * * 'Range(Cells(i, 1), Cells(i, 2)).Select
 * * * *Cells(i, 2).EntireRow.Delete
* * End If
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.DisplayAlerts = True
End Sub

Нет, не подходит, если строк будет 200 000 то Excel зависает минут на 20, может возможно решить эту задачу через массивы или еще как нибудь?

toiai · 04.08.2014, 18:08

Попробуй так, заменив цикл кодом:

Visual Basic

1	Range("B1:B" & ActiveSheet.UsedRange.Rows.Count).SpecialCells(xlCellTypeBlanks).Rows.Delete

Аксима · 04.08.2014, 19:38

toiai, сначала тоже думал в эту сторону

. Потом подготовил тестовый лист с 200000 строками, сформированными по следующему принципу: нечетные - непустые, четные - пустые. И представь себе, код со SpecialCells такой краш-тест не прошел...

В общем, соглашусь с ТС, выход один - использовать массивы...

Visual Basic

Sub DeleteRowsNullStringsB()
    Dim i As Long, n As Long, m As Long, k As Long
    Dim rng As Range, arr() As Variant
    Set rng = Cells(Cells.Rows.Count, 1)
    'Формируем массив, состоящий из значений столбцов "A" и "B"
    'от первой строки до последней заполненной в столбце "A".
    If Not IsEmpty(rng) Then Set rng = Range("A:B") Else Set rng = Range(Range("B1"), rng.End(xlUp))
    arr = rng
    'Формируем из данного массива новый, во втором столбце которого
    'нет значений, эквивалентных константе vbNullString.
    n = UBound(arr)
    m = n - Evaluate("COUNTBLANK(" & rng.Columns(2).Address & ")")
    ReDim arr2(1 To m, 1 To 2) As Variant
    For i = 1 To n
        If arr(i, 2) <> vbNullString Then
            k = k + 1
            arr2(k, 1) = arr(i, 1)
            arr2(k, 2) = arr(i, 2)
        End If
    Next i
    'Очищаем столбцы "A:B" от старых данных.
    Range("A:B").Clear
    'Выгружаем на лист сформированный массив.
    Cells(1).Resize(m, 2) = arr2
End Sub

На тестовом листе такая программа отработала быстрее чем за секунду.

С уважением,

Aksima

@Egor.V.A · 05.08.2014, 09:25 **[ТС]**

Сообщение от Aksima

m = n - Evaluate("COUNTBLANK(" & rng.Columns(2).Address & ")")

На этой строчке выдает ошибку:
Run-time error '13':
Type mismatch

Аксима · 05.08.2014, 11:19

Egor.V.A, можно ли попросить вас сделать файл, в котором воспроизводится ошибка, и выложить его на форум?

Обычно я с удовольствием играю в телепата, но сегодня что-то не хочется

.

С уважением,

Aksima

@Egor.V.A · 05.08.2014, 12:02 **[ТС]**

Да, конечно можно ))) Прошу прощения.

Аксима · 05.08.2014, 13:05

Egor.V.A, спасибо!

Исправил процедуру, сделав ее более отказоустойчивой.

Процедура удаления строк по условию - вариант с повышенной отказоустойчивостью

Visual Basic

Sub DeleteRowsEnhancedSafety()
    Dim i As Long, n As Long, m As Long, k As Long
    Dim rng As Range, arr() As Variant, response As VbMsgBoxResult
    Set rng = Cells(Cells.Rows.Count, 1)
    'Формируем массив, состоящий из значений столбцов "A" и "B"
    'от первой строки до последней заполненной в столбце "A".
    If Not IsEmpty(rng) Then Set rng = Range("A:B") Else Set rng = Range(Range("B1"), rng.End(xlUp))
    arr = rng
    'Формируем из данного массива новый, во втором столбце которого
    'нет значений, эквивалентных константе vbNullString.
    n = UBound(arr)
 
    'Вычислим количество непустых ячеек в диапазоне столбца "B".
    'При этом адрес диапазона передается в том же стиле ссылок,
    'который выставлен в приложении. В противном случае может
    'возникнуть ситуация, когда в приложении используется стиль
    'ссылок R1C1, а мы передаем ей адрес в стиле A1. В этом случае
    'функция не сможет распознать адрес и вернет ошибку (а ошибки
    'со значениями не сравниваются - "Type Mismatch"!)
 
    m = n - Evaluate("COUNTBLANK(" & rng.Columns(2).Address(ReferenceStyle:=Application.ReferenceStyle) & ")")
    'Альтернативная поправка для предыдущей строки.
    'm = n - Application.WorksheetFunction.CountBlank(rng.Columns(2))
 
    'Учтем случай, когда в столбце "B" есть только пустые ячейки и ячейки с vbNullString.
    If m = 0 Then
        response = MsgBox("В столбце ""B"" есть только пустые ячейки и ячейки с vbNullString. Удалить все значения столбцов ""A"" и ""B""?", vbYesNo, "Потверждение операции")
        If response = vbYes Then Range("A:B").Clear Else MsgBox "Операция отменена пользователем.", , "Информация"
        Exit Sub
    End If
    ReDim arr2(1 To m, 1 To 2) As Variant
    For i = 1 To n
        'Учтем случай, когда столбец "B" содержит коды ошибок (которые несравнимы с vbNullString)
        If IsError(arr(i, 2)) Then
            k = k + 1
            arr2(k, 1) = arr(i, 1)
            arr2(k, 2) = arr(i, 2)
        ElseIf arr(i, 2) <> vbNullString Then
            k = k + 1
            arr2(k, 1) = arr(i, 1)
            arr2(k, 2) = arr(i, 2)
        End If
    Next i
 
    'Очищаем столбцы "A:B" от старых данных.
    Range("A:B").Clear
    'Выгружаем на лист сформированный массив.
    Cells(1).Resize(m, 2) = arr2
End Sub

С уважением,

Aksima

@larusso · 03.10.2017, 06:40

аксима, увидел алгоритм удаления пустых строк - спасибки
решил переделать под себя
все получается, но у меня столбцов более 10.
руками "перебирать строки 36,37 алгоритма лень
написал новый цикл
но получается так, что если цикл

Visual Basic

  Dim i As Long, n As Long, m As Long, k As Long, a As Long
      Dim LastColumn%
      LastColumn = ActiveSheet.Cells(10, Columns.Count).End(xlToLeft).Column
      ElseIf arr(i, 3) <> vbNullString Then
          k = k + 1
            For a = 1 To LastColumn
               arr2(k, a) = arr(i, a)
               a = a + 1
            Next a
        End If

, то выгружаются нечетные столбцы массива
а если

Visual Basic

  Dim i As Long, n As Long, m As Long, k As Long, a As Long
      Dim LastColumn%
      LastColumn = ActiveSheet.Cells(10, Columns.Count).End(xlToLeft).Column
      ElseIf arr(i, 3) <> vbNullString Then
          k = k + 1
            For a = 1 To LastColumn
               a = a + 1
               arr2(k, a) = arr(i, a)
            Next a
        End If

, то - четные
что не так? как правильно написать, чтоб выгружалось все?

Добавлено через 21 минуту
ссори, хорощая мысля приходит опосля))))
по невнимательности поставил a=a+1
)))))))
вопрос снят

Удаление строк по условию

Решение

Решение

@snipe 4079 / 1459 / 401 Регистрация: 07.08.2013 Сообщений: 3,645
	01.08.2014, 10:43	3
	такое возможно Добавлено через 3 минуты 1.напишите название столбцов 2.поставьте автофильтр 3.включите рекордер записи макроса 4. отфильтруйте записи 5. удалите ненужные записи 6. отключите рекордер записи макроса 7. нажмите alt+f11 8. посмотрите что написал сам Excel думаю вы приятно удивитесь 1

@Egor.V.A 0 / 0 / 2 Регистрация: 01.06.2012 Сообщений: 139
	05.08.2014, 09:25 [ТС]	8
	Сообщение от Aksima m = n - Evaluate("COUNTBLANK(" & rng.Columns(2).Address & ")") На этой строчке выдает ошибку: Run-time error '13': Type mismatch 0

Аксима 6082 / 1326 / 195 Регистрация: 12.12.2012 Сообщений: 1,023
	05.08.2014, 11:19	9
	Egor.V.A, можно ли попросить вас сделать файл, в котором воспроизводится ошибка, и выложить его на форум? Обычно я с удовольствием играю в телепата, но сегодня что-то не хочется . С уважением, Aksima 1