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

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