使用VBA删除每个第2和第3行

问题描述：

我在寻找有关快速删除中等大小数据集的三分之二的见解。目前，我正在将空格分隔的数据从文本文件导入到Excel中，并且我正在使用循环逐行删除数据。循环从数据的最底行开始，并删除上行。数据按时间顺序排列，我不能简单地砍掉数据的前三分之二或三分之二。基本上，发生的情况是数据被过度采样，太多的数据点彼此靠得太近。这是一个非常缓慢的过程，我只是在寻找另一种方法。使用VBA删除每个第2和第3行

Sub Delete() 

Dim n As Long 

n = Application.WorksheetFunction.Count(Range("A:A")) 

Application.Calculation = xlCalculationManual 

Do While n > 5 

n = n - 1 
Rows(n).Delete 
n = n - 1 
Rows(n).Delete 
n = n - 1 

Loop 

    Application.Calculation = xlCalculationAutomatic 

End Sub

另外，我看着多选择所有感兴趣的行中循环，执行与一行代码中删除所有行的选择后，却无法弄清楚一种做法。我会认为这可能会增加整体计算时间。 – Jesse

答

for循环使用，通过一定数目的允许步进：

For i = 8 To n Step 3

使用联盟创建存储在一个范围内变化脱节的范围。

Set rng = Union(rng, .Range(.Cells(i + 1, 1), .Cells(i + 2, 1)))

然后一次全部删除。

rng.EntireRow.Delete

另一个好习惯，鼓励是宣布任何范围对象的父使用ALWAYS。随着你的代码变得越来越复杂，没有宣布父母会导致问题。

通过使用With块。

With Worksheets("Sheet1")

，我们可以先全部范围对象与.表示链接到该父。

Set rng = .Range("A6:A7")

Sub Delete() 

Dim n As Long 
Dim i As Long 
Dim rng As Range 

Application.Calculation = xlCalculationManual 

With Worksheets("Sheet1") 'change to your sheet 
    n = Application.WorksheetFunction.Count(.Range("A:A")) 

    Set rng = .Range("A6:A7") 

    For i = 8 To n Step 3 
     Set rng = Union(rng, .Range(.Cells(i + 1, 1), .Cells(i + 2, 1))) 
    Next i 
End With 

rng.EntireRow.Delete 

Application.Calculation = xlCalculationAutomatic  


End Sub

谢谢，明天我会试试这个。你期望使用这种方法看到计算时间大大减少吗？ – Jesse

@Jesse是的，因为它只做删除一次。 –

我使用小数据集将您的方法与原始方法进行了比较，速度大约快225％。使用相同的数据集，循环需要执行519s和231s。这两套代码都包含在一个.xlsm中，其中包含很多其他工作表，模块等。然后我把我的原始代码插入到一个空的.xlsm中，并再次计时，并执行了71s。我假设你的方法在一个空的.xlsm中需要30秒。所以我的下一个问题：是否有任何其他属性，我可以在循环中禁用，以加快速度？ – Jesse

答

你可以使用数组和写出来的行的三分之一到一个新的数组。然后在清除原稿后打印出来。

如果有的话，你会失去公式。如果你只有一个基本数据集，这可能适合你。它应该是快

Sub MyDelete() 
    Dim r As Range 
    Set r = Sheet1.Range("A1").CurrentRegion 'perhaps define better 
    Set r = r.Offset(1, 0).Resize(r.Rows.Count - 1) ' I assume row 1 is header row. 

Application.ScreenUpdating = False 

    Dim arr As Variant 
    arr = r.Value 

    Dim newArr() As Variant 
    ReDim newArr(1 To UBound(arr), 1 To UBound(arr, 2)) 
    Dim i As Long, j As Long, newCounter As Long 
    i = 1 
    newCounter = 1 

    Do 
     For j = 1 To UBound(arr, 2) 
      newArr(newCounter, j) = arr(i, j) 
     Next j 

     newCounter = newCounter + 1 
     i = i + 3 
    Loop While i <= UBound(arr) 

    r.ClearContents 
    Sheet1.Range("A2").Resize(newCounter - 1, UBound(arr, 2)).Value = newArr 

Application.ScreenUpdating = True 

End Sub

使用VBA删除每个第2和第3行

相关推荐