Question

我有 250.000行，我想删除col AR中0的所有行。这需要花费太多时间使用过滤器并仅删除可见单元格，因此我编写了一个代码。 1000线还需要1分钟。所以我将需要250分钟！除了前6分钟（6k行）后，AS3中的数字（见下面的代码）冻结，所以我不知道它是否还在运行。

有没有办法更有效地做到这一点（使用更少的时间）？

我的代码是：

Sub delrow()


Application.Calculation=xlCalculationManual


With Sheets("bners")
LR3 = Range("A" & Rows.Count).End(xlUp).Row
For i3 = 3 To LR3
range("AS2")=i3
    a = Sheets("bners").Range("AR" & i3).Value
    If a = 0 Then
    Rows(i3).Delete
    Else
    End If
Next i3
End With

Application.calculate


End Sub

谢谢！

Answer 1

是的，绝对是Step -1。但是这一点能让它变得快吗？这一次批量删除10（如果现在需要）。

Option Explicit
Dim ws as Range

Sub delrow1()
  Dim LR3&, i3&, a&
  Set ws = Sheets("bners")
  LR3 = ws.Range("A" & Rows.Count).End(xlUp).Row
  For i3 = LR3 To 3 Step -1
    a = ws.Cells(i3, "AR").Value
    If a = 0 Then
      Call delrow2(i3)
    End If
  Next i3
  Call delrow2(0) ' flush
End Sub

Sub delrow2(delRow&) ' deletes 10 rows at a time
  Static a1&(10), na1&
  Dim i1&, zRange As Range
  If delRow = 0 Then ' finish;end;flush
    For i1 = 1 To na1
      ws.Rows(a1(i1)).Delete
    Next i1
    na1 = 0
  Else ' store row in array a1
    na1 = na1 + 1
    a1(na1) = delRow
    If na1 = 10 Then ' del 10 rows
      Set zRange = Union( _
        Rows(a1(1)), Rows(a1(2)), Rows(a1(3)), Rows(a1(4)), Rows(a1(5)), _
        Rows(a1(6)), Rows(a1(7)), Rows(a1(8)), Rows(a1(9)), Rows(a1(10)))
      ws.Range(zRange).Rows.Delete
      na1 = 0
    End If
  End If

Answer 2

我喜欢几周前发现的这种方法，但直到昨晚才记得http://goo.gl/NYtY9R可以很容易地适应你的方法

Sub RowKiller()
    Dim F As Range, rKill As Range
    Set F = Range("A2:A250000")
    Set rKill = Nothing
    For Each r In F
        v = r.Text
        If InStr(1, v, "0") = 1 Then
            If rKill Is Nothing Then
                Set rKill = r
            Else
                Set rKill = Union(r, rKill)
            End If
        End If
    Next r

    If Not rKill Is Nothing Then
        rKill.EntireRow.Delete
    End If
End Sub

对我非常有效，因为它会建立联盟，然后一次删除所有内容，而不是一次删除一个。

Answer 3

在示例中，您with sheets()完全无用，因为您忘记了每个点“。”在cells或range或rows之前。

我将尝试另一种方法，使用两个VBA阵列（未经过测试，可能存储器溢出）。第一个数组是宏之前的原始数据。第二个数组是宏

之后的数据

我不会删除行，我只是从第一个数组的好行写出第二个数组，然后将其粘贴到工作表上

Sub RowKill()

'Declaring Variables :
Dim MaxRows as long   'number of lines in the First Array
Dim NewRows as Long   'number of lines in the Second Array
Dim q as long         'simple loop counter
Dim i as long         'simple loop counter , for the purpose of copying line
Dim Rg As Range       'Range of the original Data (number of lines = MaxRows-2, because the Original example code starts at 3, not 1)
Dim Sh as Worksheet
Dim Array1() as variant 'First VBA Array
Dim Array2() as variant 'Second VBA Array



with Application
     .enableevents=false
     .screnupdating=false
     .Calculation=xlCalculationManual
end with

set Sh=thisworkbook.Sheets("bners")

with Sh
    MaxRows = .Range( .Rows.Count , 44).End(xlUp).Row ' note the .rows, and i read on cloumn 44 and not 1
    Set Rg = .Range( .cells(3,44) , .cells ( MaxRows,44) ) '44 is the column of .range("AR")
    'The Range Rg is important , later we delete the whole thing ^^
    Redim Array1 ( 1 to MaxRows, 1 to 44)  'Only if "AR" is your last column
    Array1 = Rg.value2 'if you work with dates or time format in your cells, please replace by : Array1 = Rg.value



    for q= 3 to MaxRows

        if Array1 (q , 44) <> 0 Then 'wasn't sure, because empty cells will trigger too, in wich case: <>"" would be better, or: If not IsEmpty( Array1 (q,44))    .....
            call CopyRowToSecondArray ( q , NewRows , Array2)
        End If

    next q

End With 'Sh

'Rg.delete  'old version


With Sh 
     .range ( .cells(1,1) , .cells (44 , NewRows).Value2 = Array2 ' again use .value, if you have date or time formating inside the data cells
     if NewRows<MaxRows then .range ( .cells(1,NewRows+1) , .cells (44 , MaxRows).Value2 = ""
End with

with Application
     .enableevents= True
     .screnupdating= True
     .Calculation=xlCalculationAutomatic
end with

Set Rg = Nothing
Ser Sh = Nothing
Erase Array1, Array 2

End Sub


Sub CopyRowToSecondArray ( byval q as long , byref NewRows as long , byref Array2 as variant)
Dim i as long
NewRows=NewRows+1
Redim Preserve Array2 (1 to NewRows, 1 to 44)
for i = 1 to 44  'this entire for i loop, might be faster with unknown vba array function (i'm new), please share with me
     Array2 ( NewRows , i) = Array1 ( q , i )
next i
end sub

也许有一种更好的方法可以简单地将整行从一个阵列复制到另一个阵列，我不知道......

代码未经测试，并且我假设44是最后一列（仅在循环中更改，如果需要则更改为Rg），因此在测试我的代码之前复制您的工作。

希望这会有所帮助，而且速度更快。

vba循环性能太多时间

3 个答案: