更快的方法一次删除行40k +行
有更快的方法来删除行吗？
我只需要删除从第3行到最后一行有奇数行数据的行
下面的代码工作，但很慢：
Dim toDelete As Range For icount = endRow To 3 Step -2 If toDelete Is Nothing Then Set toDelete = Rows(icount) Else Set toDelete = Union(toDelete, Rows(icount)) End If Next toDelete.Delete shift:=xlUp 我已经发布了这个解决scheme ，但是当address超过一定长度时，它是在Range(address)的上下文中抛出错误的。
但现在的话题是严格删除许多行的最快方式，我会假设它需要坚持实际删除行（即保留格式，公式，公式引用…）
所以我会再次在这里发布解决scheme（在“按地址删除”方法的标题下）以及第二个（“按sorting删除”方法），其速度要快得多（第一个需要20秒，第二个需要0 ，2秒处理一些40k行，即删除20k行）
这两个解决scheme稍微专门化后， For icount = endRow To 3 Step -2东西，但它可以很容易地变得更加通用
“按地址删除”的方法
Option Explicit Sub main() Dim icount As Long, endrow As Long Dim strDelete As String With Worksheets("Delete") For icount = .Cells(.Rows.Count, "C").End(xlUp).Row To 3 Step -2 strDelete = strDelete & "," & icount & ":" & icount Next icount End With DeleteAddress Right(strDelete, Len(strDelete) - 1) End Sub Sub DeleteAddress(ByVal address As String) Dim arr As Variant Dim iArr As Long Dim partialAddress As String arr = Split(address, ",") iArr = LBound(arr) Do While iArr < UBound(arr) partialAddress = "" Do While Len(partialAddress & arr(iArr)) + 1 <= 250 And iArr < UBound(arr) partialAddress = partialAddress & arr(iArr) & "," iArr = iArr + 1 Loop If Len(partialAddress & arr(iArr)) <= 250 Then partialAddress = partialAddress & arr(iArr) iArr = iArr + 1 Else partialAddress = Left(partialAddress, Len(partialAddress) - 1) End If Range(partialAddress).Delete shift:=xlUp Loop End Sub
“删除bySort”的方法
Option Explicit Sub main() Dim nRows As Long Dim iniRng As Range With Worksheets("Delete") nRows = .Cells(.Rows.Count, "C").End(xlUp).Row .Cells(1, .UsedRange.Columns(.UsedRange.Columns.Count + 1).Column).Resize(nRows) = Application.Transpose(GetArray(nRows, 3)) With .UsedRange .Sort key1:=.Columns(.Columns.Count), Header:=xlNo Set iniRng = .Columns(.Columns.Count).Find(what:=nRows + 1, LookIn:=xlValues, lookat:=xlWhole) .Columns(.Columns.Count).ClearContents End With .Range(iniRng, iniRng.End(xlDown)).EntireRow.Delete End With End Sub Function GetArray(nRows As Long, iniRow As Long) Dim i As Long ReDim arr(1 To nRows) As Long For i = 1 To nRows arr(i) = i Next i For i = nRows To iniRow Step -2 arr(i) = nRows + 1 Next i GetArray = arr End Function
Sub Delete() Dim start: start = Timer Dim Target As Range Dim Source(), Data() Dim lastRow As Long, x As Long, x1 As Long, y As Long With Worksheets("Sheet1") lastRow = .Range("A" & .Rows.Count).End(xlUp).Row Set Target = Intersect(.Rows(5 & ":" & lastRow), .UsedRange) End With Debug.Print "Rows: " & Target.Rows.Count, "Columns: " & Target.Columns.Count Source = Target.Value ReDim Data(1 To Target.Rows.Count, 1 To Target.Columns.Count) For x = 1 To UBound(Source, 1) Step 2 x1 = x1 + 1 For y = 1 To UBound(Source, 2) Data(x1, y) = Source(x, y) Next Next Target.ClearContents Target.Resize(x1).Value = Data With Worksheets("Sheet1") lastRow = .Range("A" & .Rows.Count).End(xlUp).Row Set Target = Intersect(.Rows(5 & ":" & lastRow), .UsedRange) End With Debug.Print "Rows: " & Target.Rows.Count, "Columns: " & Target.Columns.Count Debug.Print "Time in Second(s): "; Timer - start End Sub Sub Test() Dim r As Range Application.ScreenUpdating = False For Each r In [A1:H80000] r = r.Address Next r Application.ScreenUpdating = True End Sub
