excel - 在 VBA 中加速循环

Question

我正在尝试使用超过 25,000 个行项目加速 VBA 中的循环

我的代码正在通过包含超过 25,000 行的电子表格逐步下降。现在，代码循环认为每个单元格查看先前单元格值是否与当前单元格值匹配。如果它们不匹配，则插入一个新的空行。现在，代码需要 5 个多小时才能在一台速度非常快的计算机上完成。有什么办法可以加快速度吗？

With ActiveSheet
    BottomRow4 = .Cells(.Rows.Count, "E").End(xlUp).Row
    End With

Do
    Cells(ActiveCell.Row, 5).Select

    Do
        ActiveCell.Offset(1, 0).Select

    'Determines if previous cells is the same as current cells
Loop Until (ActiveCell.Offset(0, -1) & ActiveCell <> 
ActiveCell.Offset(1, -1) & ActiveCell.Offset(1, 0))

    'Insert Blank Row if previous cells do not match current cells...
    Rows(ActiveCell.Offset(1, 0).Row & ":" & ActiveCell.Offset(1, 
0).Row).Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

    BottomRow4 = BottomRow4 + 1

Loop Until ActiveCell.Row >= BottomRow4

Answer 1

与删除行时类似，您可以保存插入内容，直到完成循环。

在选择要插入的列顶部的单元格后运行(但不是在第 1 行):

Sub Tester()

    Dim c As Range, rngIns As Range, sht As Worksheet
    Dim offSet As Long, cInsert As Range

    Set sht = ActiveSheet

    For Each c In sht.Range(Selection, _
              sht.Cells(sht.Rows.Count, Selection.Column).End(xlUp)).Cells

        offSet = IIf(offSet = 0, 1, 0) '<< toggle offset

        If c.offSet(-1, 0).Value <> c.Value Then
            'This is a workaround to prevent two adjacent cells from merging in
            ' the rngInsert range being built up...
            Set cInsert = c.offSet(0, offSet)

            If rngIns Is Nothing Then
                Set rngIns = cInsert
            Else
                Set rngIns = Application.Union(cInsert, rngIns)
            End If
        End If
    Next c

    If Not rngIns Is Nothing Then
        rngIns.EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    End If

End Sub

编辑:在使用 ="Val_" & ROUND(RAND()*1000) 填充的 25k 行上运行 3 秒，转换为值，然后排序。