Help improving macro performance

[ODrumea]

Hello forum,
I have a workbook with the following code:

Sub splitByColI()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Dim r As Range, i As Long, ar
Set r = Worksheets("WorksheetName").Range("I99999").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, vbLf)
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub

In the column I have specified, I have cells with multiple lines of data that I want broken out in individual rows. The macro does the job well, my only qualm with it being that it takes a very long time even though my current data set has less than 1k rows.
Looking for any suggestions that may help improve performance.

Thank you,
Oana

 

[Jimmypop]

Hi there... Note this is untested at the moment

There are a few changes you can make to improve the performance of your macro:

1. Disable events: When the macro inserts rows, Excel may trigger events that slow down the macro. You can disable events by adding Application.EnableEvents = False at the beginning of your macro and Application.EnableEvents = True at the end.
2. Use arrays instead of copying and inserting rows: Copying and inserting rows can be slow, especially if you have a large dataset. Instead of copying and inserting rows, you can use arrays to manipulate the data in memory, and then write the updated data back to the worksheet. This approach can be much faster than copying and inserting rows.
3. Use the LastRow property to find the last row: Instead of using Range("I99999").End(xlUp) to find the last row, you can use the LastRow property to find the last row with data in column I. Here's how you can define the LastRow property:

LastRow = Worksheets("WorksheetName").Cells(Rows.Count, "I").End(xlUp).Row

Avoid using the EntireRow property: Instead of using r.EntireRow and r.Offset(1).EntireRow, you can use Range("I" & r.Row) and Range("I" & r.Row + 1) to work with the cells in column I. This can be faster than using the EntireRow property.

Here's the modified code:

Sub splitByColI()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim r As Range, i As Long, ar
Dim LastRow As Long
Dim arrData As Variant
Dim arrTemp As Variant

LastRow = Worksheets("WorksheetName").Cells(Rows.Count, "I").End(xlUp).Row
Set r = Worksheets("WorksheetName").Range("I" & LastRow)

arrData = Worksheets("WorksheetName").Range("I1:I" & LastRow).Value

Do While r.Row > 1
    ar = Split(r.Value, vbLf)
    If UBound(ar) >= 0 Then
        arrData(r.Row, 1) = ar(0)
    End If
    If UBound(ar) > 0 Then
        ReDim arrTemp(1 To UBound(ar), 1 To 1)
        For i = UBound(ar) To 2 Step -1
            arrTemp(UBound(ar) - i + 2, 1) = ar(i)
        Next
        arrData = InsertRows(arrData, r.Row + 1, arrTemp)
    End If
    Set r = r.Offset(-1)
Loop

Worksheets("WorksheetName").Range("I1:I" & LastRow).Value = arrData

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub

Function InsertRows(arrData, intStartRow, arrInsertData)
    Dim arrResult As Variant
    Dim intRows As Long
    Dim intCols As Long
    Dim intIndex As Long

    intRows = UBound(arrData, 1) + UBound(arrInsertData, 1)
    intCols = UBound(arrData, 2)

    ReDim arrResult(1 To intRows, 1 To intCols)

    For intIndex = 1 To intRows
        If intIndex < intStartRow Then
            arrResult(intIndex, 1) = arrData

    Next intIndex

    InsertRows = arrResult
End Function

 

[ODrumea]

Hi there... Note this is untested at the moment

There are a few changes you can make to improve the performance of your macro:

1. Disable events: When the macro inserts rows, Excel may trigger events that slow down the macro. You can disable events by adding Application.EnableEvents = False at the beginning of your macro and Application.EnableEvents = True at the end.
2. Use arrays instead of copying and inserting rows: Copying and inserting rows can be slow, especially if you have a large dataset. Instead of copying and inserting rows, you can use arrays to manipulate the data in memory, and then write the updated data back to the worksheet. This approach can be much faster than copying and inserting rows.
3. Use the LastRow property to find the last row: Instead of using Range("I99999").End(xlUp) to find the last row, you can use the LastRow property to find the last row with data in column I. Here's how you can define the LastRow property:

LastRow = Worksheets("WorksheetName").Cells(Rows.Count, "I").End(xlUp).Row

Avoid using the EntireRow property: Instead of using r.EntireRow and r.Offset(1).EntireRow, you can use Range("I" & r.Row) and Range("I" & r.Row + 1) to work with the cells in column I. This can be faster than using the EntireRow property.

Here's the modified code:

Sub splitByColI()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim r As Range, i As Long, ar
Dim LastRow As Long
Dim arrData As Variant
Dim arrTemp As Variant

LastRow = Worksheets("WorksheetName").Cells(Rows.Count, "I").End(xlUp).Row
Set r = Worksheets("WorksheetName").Range("I" & LastRow)

arrData = Worksheets("WorksheetName").Range("I1:I" & LastRow).Value

Do While r.Row > 1
    ar = Split(r.Value, vbLf)
    If UBound(ar) >= 0 Then
        arrData(r.Row, 1) = ar(0)
    End If
    If UBound(ar) > 0 Then
        ReDim arrTemp(1 To UBound(ar), 1 To 1)
        For i = UBound(ar) To 2 Step -1
            arrTemp(UBound(ar) - i + 2, 1) = ar(i)
        Next
        arrData = InsertRows(arrData, r.Row + 1, arrTemp)
    End If
    Set r = r.Offset(-1)
Loop

Worksheets("WorksheetName").Range("I1:I" & LastRow).Value = arrData

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayStatusBar = True
Application.ScreenUpdating = True
End Sub

Function InsertRows(arrData, intStartRow, arrInsertData)
    Dim arrResult As Variant
    Dim intRows As Long
    Dim intCols As Long
    Dim intIndex As Long

    intRows = UBound(arrData, 1) + UBound(arrInsertData, 1)
    intCols = UBound(arrData, 2)

    ReDim arrResult(1 To intRows, 1 To intCols)

    For intIndex = 1 To intRows
        If intIndex < intStartRow Then
            arrResult(intIndex, 1) = arrData

    Next intIndex

    InsertRows = arrResult
End Function

Thank you very much for your reply!
I tried running your code on a backup version of my workbook and I'm getting the following error when I try to run the sub and it highlights the very first line of the code:

If I try to run it all at once I get:

 

[welshgasman]

Last error is probably due to a missing End If ?

  For intIndex = 1 To intRows
        If intIndex < intStartRow Then
            arrResult(intIndex, 1) = arrData

    Next intIndex

 

[ODrumea]

Last error is probably due to a missing End If ?

  For intIndex = 1 To intRows
        If intIndex < intStartRow Then
            arrResult(intIndex, 1) = arrData

    Next intIndex

Right you are, I didn't catch that. Thank you!

 

[MARK858]

You can make it one line as it is only doing the one test, then you don't need the End If

  For intIndex = 1 To intRows
        If intIndex < intStartRow Then arrResult(intIndex, 1) = arrData
  Next intIndex

 

[ODrumea]

I ran into a different issues which is the fact that my laptop doesn't have enough memory to run the code
I don't have other instances of excel open and closed email, browser windows and still no luck.