Search code examples
excelvbaperformance

VBA Macro to format excel report needs performance improvement

I have a VBA macro which inserts a blank line to an excel whenever level column value in current row is not a consecutive number to the level value in previous row, another condition I use is if level in two consecutive rows is same then skip inserting blank line. It works well to format my excel report but for a report with 4,50,000 (0.45 million) rows it takes around 18 mins to complete which is definitely a performance hit.

My VBA Code is

Sub test()

Dim i As Long
Dim a As Long
Dim x As Integer
Dim r As Range

a = Cells(Rows.Count, "A").End(xlUp).Row

'MsgBox a

For i = a To 6 Step -1

    'MsgBox i

    x = Cells(i, "A").Value - Cells(i - 1, "A").Value

   ' MsgBox x

    If Not (x = 0) And Not (x = 1) Then

    Rows(i).Resize(1).Insert

    End If

Next

End Sub

I can not make much use of external scripts or manual solutions as I need to offer a formatted report as a final output without any post processing steps. Hence trying to achieve this using a macro.

Any suggestions to improve this performance will be really helpful.

Sample Input

Solution
    • Using an array to transform data and write output to sheet all at once will imporve efficiency Note: please backup your file before testing.
    Option Explicit

Sub Demo()
    Dim i As Long, j As Long, r As Long
    Dim arrData, arrRes, lastRow As Long, ColCnt As Long
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    arrData = Range("A7:F" & lastRow).Value
    ColCnt = UBound(arrData, 2)
    ReDim arrRes(1 To UBound(arrData) * 2, 1 To ColCnt)
    r = 1
    For j = 1 To ColCnt
        arrRes(r, j) = arrData(1, j)
    Next j
    For i = LBound(arrData) + 1 To UBound(arrData)
        If arrData(i, 1) = arrData(i - 1, 1) Or arrData(i, 1) = arrData(i - 1, 1) + 1 Then
            r = r + 1
        Else
            r = r + 2
        End If
        For j = 1 To ColCnt
            arrRes(r, j) = arrData(i, j)
        Next j
    Next i
    Range("A7").Resize(r, ColCnt).Value = arrRes
End Sub