excelvba

How to insert a blank row once value is changed in a column?


I'm trying to insert a blank row once the customer Id gets changed. I have this work but on a large scale of data takes so much time. Is there a faster approach to achieve the same? Thank you.

Public Sub SplitRanges()

Set WB = ThisWorkbook
Set StWs = WB.Sheets("data")
Dim irw As Integer, iCl As Integer
Dim oRng As Range: Set oRng = StWs.Range("E2") 'where column Customer ID

irw = oRng.Row
iCl = oRng.Column

Do
    On Error Resume Next '<-------- force it to continue as getting Over flow
    If Cells(irw + 1, iCl) <> Cells(irw, iCl) Then
        Cells(irw + 1, iCl).EntireRow.Insert shift:=xlDown
        irw = irw + 2
    Else
        irw = irw + 1
    End If
Loop While Not Cells(irw, iCl).Text = ""

End Sub

Solution

  • A faster method would be to insert all rows at once (and not one at a time) using Union to marge multiple rows to 1 range.

    Modified code

    Public Sub SplitRanges()
    
    Dim WB As Workbook, StWs As Worksheet
    Dim irw As Long, iCl As Long
    Dim oRng As Range, InsertRng As Range
    
    Application.ScreenUpdating = False
    
    
    Set WB = ThisWorkbook
    Set StWs = WB.Sheets("data")
    Set oRng = StWs.Range("E2") 'where column Customer ID
    
    irw = oRng.Row
    iCl = oRng.Column
    
    With StWs
        Do
            If .Cells(irw + 1, iCl).Value <> .Cells(irw, iCl).Value Then
                ' create a Range object with all range that meet this criteria
                If InsertRng Is Nothing Then
                    Set InsertRng = .Cells(irw + 1, iCl)
                Else
                    Set InsertRng = Application.Union(InsertRng, .Cells(irw + 1, iCl))
                End If
            End If
            
            irw = irw + 1
        Loop While Not Cells(irw, iCl).Text = ""
        
        ' verify there's at least 1 cell in range
        If Not InsertRng Is Nothing Then
            InsertRng.EntireRow.Insert Shift:=xlDown
        End If
    
    End With
    
    Application.ScreenUpdating = True
    
    End Sub
    

    Edit 1 - Loop over a 2-D array:

    Option Explicit
    
    
    Public Sub SplitRanges()
    
    Dim WB As Workbook, StWs As Worksheet
    Dim irw As Long, iCl As Long
    Dim i As Long, LastRow As Long
    Dim oRng As Range, InsertRng As Range
    Dim DataArr As Variant
    
    
    Application.ScreenUpdating = False
    
    
    Set WB = ThisWorkbook
    Set StWs = WB.Sheets("data")
    Set oRng = StWs.Range("E2") 'where column Customer ID
    
    irw = oRng.Row
    iCl = oRng.Column
    
    With StWs
        LastRow = .Cells(.Rows.Count, iCl).End(xlUp).Row ' get last row
        
        ' read entire worksheet to 2-D array
        DataArr = .Range(.Cells(1, 1), .Cells(LastRow, iCl)).Value
        
        ' -- loop over array is quicker --
        For i = irw To UBound(DataArr, 1)
            If DataArr(i + 1, iCl) <> DataArr(i, iCl) Then
                ' create a Range object with all range that meet this criteria
                If InsertRng Is Nothing Then
                    Set InsertRng = .Cells(irw + 1, iCl)
                Else
                    Set InsertRng = Application.Union(InsertRng, .Cells(irw + 1, iCl))
                End If
        
            End If
        Next i
        
        ' verify there's at least 1 cell in range
        If Not InsertRng Is Nothing Then
            InsertRng.EntireRow.Insert Shift:=xlDown
        End If
    
    End With
    
    Application.ScreenUpdating = True
    
    End Sub