使用 VBA 删除每第 2 行和第 3 行答案

【问题标题】：Deleting every 2nd and 3rd row using VBA使用 VBA 删除每第 2 行和第 3 行
【发布时间】：2018-02-14 07:09:45
【问题描述】：

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

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

【问题讨论】：

另外，我研究了在循环中多选所有感兴趣的行，并在选择所有行后用一行代码执行删除，但找不到方法这样做。我认为这可能会增加整体计算时间。

标签： excel dataset vba

【解决方案1】：

使用允许按特定数字步进的 for 循环：

For i = 8 To n Step 3

使用 Union 创建存储在范围变量中的脱节范围。

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 是的，因为它只删除一次。
我将您的方法与使用小型数据集的原始方法进行了比较，速度大约快了 225%。使用相同的数据集，循环需要 519 秒和 231 秒才能执行。两组代码都在一个 .xlsm 中，其中包含许多其他工作表、模块等。然后我将原始代码插入到一个空的 .xlsm 中并再次计时，执行时间为 71 秒。我假设你的方法在一个空的 .xlsm 中需要大约 30 秒。所以我的下一个问题是：是否有任何其他属性可以在循环期间禁用以加快速度？
@Jesse 是的，禁用所有事件和屏幕更新。确保在离开宏之前重新启用它们。请记住通过单击答案旁边的复选标记将答案标记为正确。
您能否更具体地说明禁用所有事件？我尝试禁用屏幕更新以及Application.Calculation = xlCalculationManual。我的代码在较大的电子表格中要慢得多，而且我似乎无法像在空电子表格中那样快速地执行它。

【解决方案2】：

您可以使用数组并将三分之一的行写入一个新数组。然后在清除原稿后打印到屏幕上。

如果有公式，您会丢失。如果您只有一个基本数据集，这可能适合您。应该很快

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

【讨论】：