Fastest way to delete rows which cannot be grabbed with SpecialCells

后端 未结 3 531
深忆病人
深忆病人 2020-11-28 14:49

Based on another question on this site I started wondering about the fastest way to delete all rows with a certain condition.

The above-referenced question came with

3条回答
  •  陌清茗
    陌清茗 (楼主)
    2020-11-28 15:21

    One efficient solution is to tag all the rows to keep and move all the rows to delete at the end by sorting the tags. This way, the complexity doesn't increase with the number of rows to delete.

    This example deletes in less than a second, for 50000 rows, all the rows where column I is equal to 2:

    Sub DeleteMatchingRows()
        Dim rgTable As Range, rgTags As Range, data(), tags(), count&, r&
    
        ' load the data in an array
        Set rgTable = ActiveSheet.UsedRange
        data = rgTable.Value
    
        ' tag all the rows to keep with the row number. Leave empty otherwise.
        ReDim tags(1 To UBound(data), 1 To 1)
        tags(1, 1) = 1  ' keep the header
        For r = 2 To UBound(data)
          If data(r, 9) <> 2 Then tags(r, 1) = r  ' if column I <> 2 keep the row
        Next
    
        ' insert the tags in the last column on the right
        Set rgTags = rgTable.Columns(rgTable.Columns.count + 1)
        rgTags.Value = tags
    
        ' sort the rows on the tags which will move the rows to delete at the end
        Union(rgTable, rgTags).Sort key1:=rgTags, Orientation:=xlTopToBottom, Header:=xlYes
        count = rgTags.End(xlDown).Row
    
        ' delete the tags on the right and the rows that weren't tagged
        rgTags.EntireColumn.Delete
        rgTable.Resize(UBound(data) - count + 1).Offset(count).EntireRow.Delete
    End Sub
    

    Note that it doesn't alter the order of the rows.

提交回复
热议问题