Страницы: 1
RSS
VBA: Ускорение удаления строк в умной таблице по критерию
 
Коллеги, добрый день,

Подскажите, пожалуйста, возможно ли ускорить процесс удаления строк в умной таблице с помощью VBA по сравнению с тем, что у меня в файле-примере?
Мой текущий код работает в принципе, однако если таблица большая и данных много, то процесс сильно затягивается.

Код:
Код
Sub DeletingRows()   
    Dim arrData, tblData As ListObject
    Set tblData = Sheets(1).ListObjects(1)
    arrData = tblData.Range.Value
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    For i = UBound(arrData) To 1 Step -1
        If arrData(i, 1) = Sheets(1).Range("F3").Value Then
            tblData.Range.Rows(i).Delete
        End If
    Next i
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Спасибо.
Изменено: Framed - 16.09.2019 15:33:46
 
Убрать отсюда обращение к листу
Код
If arrData(i, 1) = Sheets(1).Range("F3").Value Then
 
Код
Private Sub CommandButton1_Click()
    Dim arrData()
    Dim Compare ' что там? тип переменной?
    Dim rRng As Range

    arrData = Sheets(1).ListObjects(1).Range.Value
    Compare = Sheets(1).Range("F3").Value
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    For i = 1 To UBound(arrData)
        If arrData(i, 1) = Compare Then
            If rRng Is Nothing Then
                Set rRng = Cells(i, 1)
            Else
                Set rRng = Union(rRng, Cells(i, 1))
            End If
        End If
    Next i
    
    If Not rRng Is Nothing Then rRng.EntireRow.Delete
    
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub
 
Привет!

Во вложении небольшое ускорение.
Сравнение прайсов, таблиц - без настроек
 
Вить, этот алгоритм сошел с дистанции первым.
https://www.excel-vba.ru/forum/index.php?topic=5674.msg30322#msg30322
 
А сортировать по первому столбцу можно? Кстати, никто не подскажет как избавиться от On Error Resume Next - не нашёл как проверить, что после фильтрации у меня хоть какие-то видимые строки остались.
Код
Private Sub CommandButton1_Click()
    Dim arrData, tblData As ListObject
    Set tblData = Sheets(1).ListObjects(1)
    arrData = tblData.Range.Value
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
'    For i = UBound(arrData) To 1 Step -1
'        If arrData(i, 1) = Sheets(1).Range("F3").Value Then
'            tblData.Range.Rows(i).Delete
'        End If
'    Next i

    tblData.Sort.SortFields.Clear
    tblData.Sort.SortFields.Add tblData.ListColumns(1).Range
    tblData.Sort.Apply
     
    tblData.Range.AutoFilter Field:=1, Criteria1:=Sheets(1).Range("F3").Value
    On Error Resume Next
    tblData.DataBodyRange.SpecialCells(xlVisible).EntireRow.Delete
    On Error GoTo 0
    tblData.AutoFilter.ShowAllData
    
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Изменено: Wiss - 16.09.2019 15:52:19
Я не волшебник, я только учусь.
 
RAN, на самом деле, там немного сложнее: в оригинальной версии у меня есть массив, в котором различные значения, а макрос сранивает эти значения по каждой строке в таблице - если критерий есть, то удаляет, если нет, то оставляет. Короче говоря, от обращений к листу максимально избавился, все вычисления в массивах.

vikttur, Inexsu, спасибо, сейчас попробую.

RAN, а что значит: сошел с дистанции?

Wiss, сортировать нельзя, к сожалению, подразумевается, что критерии могут встречаться в произвольном порядке.
Страницы: 1
Наверх