Excel vba для вставки пустых строк занимает слишком много времени

Question

У меня есть макрос, который сравнивает 2 ячейки и вставляет пустую строку между ними, если они разные. Это заняло около 12 минут, чтобы завершить этот процесс с помощью этого кода:

    Worksheets("Dollars").Activate
    Range("B10").Select

'    Do Until ActiveCell.Formula = ""
'        DoEvents
'        If ActiveCell <> ActiveCell.Offset(1, 0) Then
'            ActiveCell.Offset(1, 0).Activate
'            Selection.EntireRow.Insert
'        End If
'        ActiveCell.Offset(1, 0).Activate
'    Loop

Я переписал код таким образом, чтобы посмотреть, был ли он лучше, и для его выполнения потребовалось еще 12 минут.

    Dim r As Long
    Dim vStr1 As String
    Dim vStr2 As String
    r = 10
    vStr1 = ""
    vStr2 = ""

    Do Until Len(Trim(Cells(r, 2))) = 0
        DoEvents
        vStr1 = ""
        vStr2 = ""
        vStr1 = Trim(Cells(r, 2))
        vStr2 = Trim(Cells((r + 1), 2))

        If vStr1 = vStr2 Then
'           do nothing
        Else
            Cells((r + 1), 1).EntireRow.Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            r = r + 1
        End If
        r = r + 1
    Loop

есть ли лучший способ сделать это, чтобы это не заняло так много времени? Мы используем Windows 10 и Office 2016. Спасибо за помощь. Я ценю это ....

Answer 1

Это не будет очень быстро, но должно сделать работу.

Sub x()

Dim r As Long

Application.ScreenUpdating = False

With Worksheets("Dollars")
    For r = .Range("B" & Rows.Count).End(xlUp).Row To 10 Step -1
        If .Cells(r, 2).Value <> .Cells(r - 1, 2).Value Then
            .Cells(r, 2).EntireRow.Insert
        End If
    Next r
End With

Application.ScreenUpdating = True

End Sub

Answer 2

Если вы заботитесь только о A1 <> A2 и т. Д. До конца вашего диапазона .... вы можете использовать Union, чтобы собрать целевые ячейки, в которые вы хотите вставить свои строки. Затем вставьте строки сразу в конец, выполняя это построчно. Обратите внимание, что ничего не нужно выбирать, как указано @ BigBen

---

Sub Social_Distance()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet2")

Dim lr As Long, MyUnion As Range, xCell As Range
lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

For Each xCell In ws.Range("A2:A" & lr)
    If xCell.Value <> xCell.Offset(1).Value Then
        If Not MyUnion Is Nothing Then
            Set MyUnion = Union(MyUnion, xCell.Offset(1))
        Else
            Set MyUnion = xCell.Offset(1)
        End If
    End If
Next xCell

If Not MyUnion Is Nothing Then MyUnion.EntireRow.Insert Shift:=xlDown

End Sub

Answer 3

Вообще говоря, вставка большого количества строк в Excel - это производительность PITA.
Вы должны рассмотреть возможность добавления строк в конце списка и сортировки всего списка в конце процесса.
Я знаю, что это немного короткий ответ, но это все, что я могу сейчас сделать с Chromebook ...