VBA Loop - Insert row when cell, or cells, above are not equal-CodePudding

The code below works, however, I want to find a way to refine & optimise the code itself. Appreciate any guidance from members. I have checked similar questions.

enter image description here

Objective:

VBA loop an excel worksheet to identify if the data in columns B & C match the cells above. If not, insert a new row & resize the range until complete.

Sub Insert_Row_When_Data_Is_Not_Equal()

Dim x As Long
Dim LastRow As Long

LastRow = Cells(Rows.Count, 1).End(xlUp).row

'Row 2 starting point to skip headers
x = 2

'Repeat loop until end of range
Do While Range("A" & LastRow - 1).Value <> ""

x = x   1
    
    'If the combined data in B3 & C3 does not equal _
    'the data above, insert a new row & resize my range
    If Range("B" & x).Value & Range("C" & x).Value _
    <> Range("B" & x - 1).Value & Range("C" & x - 1).Value Then
    
        Range("B" & x).EntireRow.Insert
        
        x = x   1
        
        LastRow = Cells(Rows.Count, 1).End(xlUp).row
    
    End If
Loop

'Just for validation
Debug.Print LastRow

End Sub

CodePudding user response：

It usually preferable to scan up the sheet when inserting or deleting rows so the loop counter is not affected.

Option Explicit

Sub Insert_Row_When_Data_Is_Not_Equal()

    Dim ws As Worksheet, x As Long, LastRow As Long
    Set ws = ActiveSheet
    
    With ws
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        
         ' loop up the sheet
        For x = LastRow - 1 To 2 Step -1 ' header row 1
            'If the combined data in B3 & C3 does not equal _
            'the data below, insert a new row below
            If .Cells(x, "B").Value = .Cells(x   1, "B").Value Then
                If .Cells(x, "C").Value <> .Cells(x   1, "C").Value Then
                    .Rows(x   1).Insert
                End If
            Else
                .Rows(x   1).Insert
            End If
        Next
        ' recalc size
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With
    
    'Just for validation
    Debug.Print LastRow

End Sub

CodePudding user response：

Insert Row After Group

This will run fast for up to a few thousand, maybe 5 thousand rows to be inserted.

Option Explicit

Sub InsertRowAfterGroup()
    
    Const FirstRow As Long = 2
    Const LastRowCol As String = "A"
    Const CompareColsList As String = "B,C" ' add more
    Const MaxUnion As Long = 50 ' cells per combined range
    
    Dim ws As Worksheet: Set ws = ActiveSheet  ' improve
    
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, LastRowCol).End(xlUp).Row
    Dim RowsCount As Long: RowsCount = LastRow - FirstRow   1
    If RowsCount < 2 Then Exit Sub ' one row or no data
    
    Dim rg As Range: Set rg = ws.Cells(FirstRow, LastRowCol).Resize(RowsCount)
    Dim CompareCols() As String: CompareCols = Split(CompareColsList, ",")
    Dim cUpper As Long: cUpper = UBound(CompareCols)
    Dim jcData As Variant: ReDim jcData(0 To cUpper)
    
    Dim c As Long
    For c = 0 To cUpper
        jcData(c) = rg.EntireRow.Columns(CompareCols(c)).Value
    Next c
    
    Dim coll As Collection: Set coll = New Collection

    Dim irg As Range ' Insert Range
    Dim iCell As Range
    Dim r As Long
    Dim irCount As Long ' Inserted Rows Count
    
    For Each iCell In rg.Cells
        r = r   1
        If r > 1 Then ' skip the first row
            For c = 0 To cUpper
                If StrComp(CStr(jcData(c)(r, 1)), CStr(jcData(c)(r - 1, 1)), _
                        vbTextCompare) <> 0 Then ' case-insensitive
                    irCount = irCount   1
                    If irg Is Nothing Then ' combine cells into range
                        Set irg = iCell
                    Else
                        If rCount Mod 2 = 0 Then ' alternate to get cell ranges
                            Set irg = Union(irg, iCell.Offset(, 1))
                        Else
                            Set irg = Union(irg, iCell)
                        End If
                    End If
                    If rCount Mod MaxUnion = 0 Then ' write range to collection
                        coll.Add irg
                        Set irg = Nothing
                    End If
                    Exit For
                End If
            Next c
        End If
    Next iCell
    
    
    If irCount = 0 Then Exit Sub
    If Not irg Is Nothing Then coll.Add irg
    
    Application.ScreenUpdating = False
    
    For Each irg In coll
        irg.EntireRow.Insert
    Next irg
    
    Application.ScreenUpdating = True
    
    MsgBox "Rows inserted: " & irCount, vbInformation
    
End Sub