Ускорение цикла в VBA

Question

Я пытаюсь ускорить цикл в VBA с более чем 25 000 позиций

У меня есть код, переходящий через электронную таблицу с более чем 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

Отредактировано: добавлены две опции: не проверять скорость.Я думал, что test2 () был бы быстрее, но я не уверен, в зависимости от количества строк.

Не проверено, но просто кое-что, о чем я подумал быстро.Если я вспомню, я вернусь к этому позже, потому что я думаю, что есть более быстрые способы

Sub Test1()
    Dim wsSheet         As Worksheet
    Dim arrSheet()      As Variant
    Dim collectRows     As New Collection
    Dim rowNext         As Long

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Const ColCheck      As Integer = 6

    Set wsSheet = ActiveSheet
    arrSheet = wsSheet.Range("A1").CurrentRegion

    For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
        If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then collectRows.Add rowNext
    Next rowNext

    For rowNext = 1 To collectRows.Count
        wsSheet.Cells(collectRows(rowNext), 1).EntireRow.Insert
    Next rowNext


    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Второй вариант, вставляющий все сразу: Я использовал здесь строку, потому что объединение будетизменить ряды рядом друг с другом в один больший диапазон.Вместо Range («1: 1», «2: 2») он будет создан («1: 2»), и это не будет вставлено так, как вам нужно.Я не знаю более чистого пути, но, вероятно, есть.

Sub Test2()
    Dim wsSheet         As Worksheet
    Dim arrSheet()      As Variant
    Dim collectRows     As New Collection
    Dim rowNext         As Long
    Dim strRange        As String
    Dim cntRanges       As Integer
    Dim rngAdd          As Range

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    Const ColCheck      As Integer = 6

    Set wsSheet = ActiveSheet
    arrSheet = wsSheet.Range("A1").CurrentRegion

    For rowNext = UBound(arrSheet, 1) To LBound(arrSheet, 1) + 1 Step -1
        If arrSheet(rowNext, ColCheck) <> arrSheet(rowNext - 1, ColCheck) Then
            strRange = wsSheet.Cells(rowNext, 1).EntireRow.Address & "," & strRange
            cntRanges = cntRanges + 1
            If cntRanges > 10 Then
                collectRows.Add Left(strRange, Len(strRange) - 1)
                strRange = vbNullString
                cntRanges = 0
            End If
        End If
    Next rowNext


    If collectRows.Count > 0 Then
        Dim i       As Long
        For i = 1 To collectRows.Count
            Set rngAdd = Range(collectRows(i))
            rngAdd.Insert
        Next i
    End If

    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Answer 2

Вставить, если не равно

Sub InsertIfNotEqual()

    Const cSheet As Variant = 1   ' Worksheet Name/Index
    Const cFirstR As Long = 5     ' First Row
    Const cCol As Variant = "E"   ' Last-Row-Column Letter/Number

    Dim rng As Range     ' Last Cell Range, Union Range
    Dim vntS As Variant  ' Source Array
    Dim vntT As Variant  ' Target Array
    Dim i As Long        ' Source Array Row Counter
    Dim j As Long        ' Target Array Row Counter

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    On Error GoTo ProcedureExit

    ' In Worksheet
    With ThisWorkbook.Worksheets(cSheet)
        ' Determine the last used cell in Last-Row-Column.
        Set rng = .Columns(cCol).Find("*", , xlFormulas, , , xlPrevious)
        ' Copy Column Range to Source Array.
        vntS = .Cells(cFirstR, cCol).Resize(rng.Row - cFirstR + 1)
    End With

    ' In Arrays
    ' Resize 1D Target Array to the first dimension of 2D Source Array.
    ReDim vntT(1 To UBound(vntS)) As Long
    ' Loop through rows of Source Array.
    For i = 2 To UBound(vntS)
        ' Check if current value is equal to previous value.
        If vntS(i, 1) <> vntS(i - 1, 1) Then
            ' Increase row of Target Array.
            j = j + 1
            ' Write Source Range Next Row Number to Target Array.
            vntT(j) = i + cFirstR
        End If
    Next
    ' If no non-equal data was found.
    If j = 0 Then Exit Sub

    ' Resize Target Array to found "non-equal data count".
    ReDim Preserve vntT(1 To j) As Long

    ' In Worksheet
    With ThisWorkbook.Worksheets(cSheet)
        ' Set Union range to first cell of row in Target Array.
        Set rng = .Cells(vntT(1), 2)
        ' Check if there are more rows in Target Array.
        If UBound(vntT) > 1 Then
            ' Loop through the rest of the rows (other than 1) in Target Array.
            For i = 2 To UBound(vntT)
                ' Add corresponding cells to Union Range. To prevent the
                ' creation of "consecutive" ranges by Union, the resulting
                ' cells to be added are alternating between column A and B
                ' (1 and 2) using the Mod operator against the Target Array
                ' Row Counter divided by 2.
                Set rng = Union(rng, .Cells(vntT(i), 1 + i Mod 2))
            Next
        End If
        ' Insert blank rows in one go.
        rng.EntireRow.Insert
    End With

ProcedureExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub

Answer 3

Как и при удалении строк, вы можете сохранять вставки до тех пор, пока не закончите цикл.

Запуск после выбора ячейки в верхней части столбца, в который вы хотите вставить (но не в строку 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

Редактировать: выполняется за 3 секунды на 25k строках, заполненных с помощью ="Val_" & ROUND(RAND()*1000), преобразованных в значения, затем отсортированных.