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