Excel vba 插入空白行花费的时间太长

Question

I have a macro that is comparing 2 cells and inserting a blank row between them if they are different. It was taking about 12 minutes to complete this process with this code:

    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

I rewrote the code to this way to see if it was any better and it still took over 12 minutes to run.

    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

is there a better way to do this so it doesn't take so long? We are using Windows 10 and Office 2016. Thanks for the help. I appreciate it....

Answer 1

Assuming you only care if A1 <> A2 and so on until the end of your range.... you can use a Union to gather up target cells where you want your rows to be inserted. Then, insert the rows all at once at the end rather doing so line by line. Notice that nothing needs to be selected as stated by @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 2

This will not be tremendously quick, but should do the job.

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 3

Generally speaking inserting a lot of rows in Excel is a PITA performance wise.
You should consider adding rows at the end of your list and sorting the whole list at the end of the process.
I know it's a bit short answer but it's all I can do from my Chromebook now...