Excel VBA - How to optimize this code with a lot of inserts

Question

Can you please suggest how below code can be optimize? It takes around 2 minutes in Windows and 4 plus minutes in Excel 2016 for Mac. I think I will have to use write once method, accumulating the inserts and write all at last but I am not getting the starting point.

There are initially 5718 rows and after the inserts row size is 31,003.

Function SplitDescAndProcessRateType(ByRef wsData As Worksheet, ByRef wsConv As Worksheet, ByRef exColIndx() As Integer, ByVal bookName As String, _
                                     ByRef rMessage As String) As Boolean

    Dim descColIndx As Integer, lCol As Integer, rateColIndx As Integer, eqColIndx As Integer
    Dim desc As String, weight2 As String, price As String, desc1 As String, bags2 As String, container2 As String
    Dim lRow As Long, i As Long, iIndx As Long
    Dim success As Boolean
    Dim eqDesc() As String, equipments() As String

    With application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
        .Calculation = xlCalculationAutomatic
    End With

    GetEquipmentDesc wsConv, eqDesc, equipments
    descColIndx = FindDescColumnIndex(wsData, lCol)
    rateColIndx = descColIndx + 1
    eqColIndx = rateColIndx + 1
    If descColIndx > 0 Then
        With wsData
            .Columns(rateColIndx).Resize(, 2).EntireColumn.Insert 'Bags
            .Cells(1, 11).Value = "carrier_org_id"
            .Cells(1, 15).Value = "Container"
            .Cells(1, 16).Value = "Weight"
            .Cells(1, 17).Value = "Bags"
            .Cells(1, descColIndx).Value = "Descr"
            .Cells(1, rateColIndx).Value = "ratetype"
            .Cells(1, rateColIndx + 1).Value = "equipment_type"
            .Cells(1, rateColIndx + 2).Value = "price"
            lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            lCol = lCol + 2
            i = 2
            Do While i <= lRow
                desc = .Cells(i, descColIndx).Value
                desc1 = .Cells(i, 18).Value
                weight2 = .Cells(i, 20).Value
                price = .Cells(i, 26).Value
                bags2 = .Cells(i, 21).Value
                container2 = .Cells(i, 19).Value
                If desc = "40ft DC or HC" Then
                    .Cells(i, descColIndx).EntireRow.Offset(1).Resize(2).Insert Shift:=xlDown
                    .Range(.Cells(i, 1), .Cells(i, lCol)).Copy
                    .Range(.Cells(i, 1).Offset(1), .Cells(i + 2, lCol)).PasteSpecial Paste:=xlPasteValues
                    .Cells(i, descColIndx).Value = desc1
                    .Cells(i + 1, descColIndx).Value = "40ft DC"
                    .Cells(i + 2, descColIndx).Value = "40ft HC"
                    .Cells(i + 1, 16).Value = weight2
                    .Cells(i + 2, 16).Value = weight2
                    .Cells(i, 25).HorizontalAlignment = xlRight
                    .Cells(i + 1, 25).Value = price
                    .Cells(i + 2, 25).Value = price
                    .Cells(i, rateColIndx).Value = "ratetype1"
                    .Cells(i + 1, rateColIndx).Value = "ratetype2"
                    .Cells(i + 2, rateColIndx).Value = "ratetype2"

                    .Cells(i, eqColIndx).Value = GetEquipmentType(eqDesc, equipments, desc1)
                    .Cells(i + 1, eqColIndx).Value = GetEquipmentType(eqDesc, equipments, "40ft DC")
                    .Cells(i + 2, eqColIndx).Value = GetEquipmentType(eqDesc, equipments, "40ft HC")

                    iIndx = 2
                ElseIf desc <> desc1 Then
                    .Cells(i, descColIndx).EntireRow.Offset(1).Resize(1).Insert Shift:=xlDown
                    .Range(.Cells(i, 1), .Cells(i, lCol)).Copy
                    .Range(.Cells(i, 1).Offset(1), .Cells(i + 1, lCol)).PasteSpecial Paste:=xlPasteValues
                    .Cells(i, descColIndx).Value = desc1
                    .Cells(i + 1, 15).Value = container2
                    .Cells(i + 1, 16).Value = weight2
                    .Cells(i + 1, 17).Value = bags2
                    .Cells(i, rateColIndx).Value = "ratetype1"
                    .Cells(i + 1, rateColIndx).Value = "ratetype2"
                    .Cells(i, eqColIndx).Value = GetEquipmentType(eqDesc, equipments, desc1)
                    .Cells(i + 1, eqColIndx).Value = GetEquipmentType(eqDesc, equipments, desc)
                    .Cells(i + 1, 25).Value = price
                    iIndx = 1
                Else
                    .Cells(i, eqColIndx).Value = GetEquipmentType(eqDesc, equipments, desc1)
                End If
                i = i + 1 + iIndx
                lRow = lRow + iIndx
                iIndx = 0
            Loop
            .Columns(26).Delete
            lCol = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
            .Cells(1, lCol).Value = "additional_notes"
            .Cells(2, lCol).Formula = "=IF(OR(OR(R2 = ""20ft DC"", R2 = ""40ft DC""),R2 = ""40ft HC""),"""",CONCATENATE(P2,""mt "",Q2,R2))"
            .Cells(2, lCol).AutoFill Destination:=.Range(.Cells(2, lCol), .Cells(lRow, lCol))
            .Columns(lCol).Calculate
            .Columns(lCol).Value = .Columns(lCol).Value
            .Range(.Cells(2, 16), .Cells(lRow, 16)).HorizontalAlignment = xlRight
            .Range(.Cells(2, 17), .Cells(lRow, 17)).HorizontalAlignment = xlRight
            .Range(.Cells(2, 21), .Cells(lRow, 21)).HorizontalAlignment = xlRight
        End With
        If i >= lRow Then
            success = True
            rMessage = rMessage & vbNewLine & "- Step 2 is complete."
        Else
            rMessage = rMessage & vbNewLine & "- Step 2: could not be completed"
        End If
    Else
            rMessage = rMessage & vbNewLine & "- Step 2: Descr2 column not found"
    End If

    With application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With

    SplitDescAndProcessRateType = success

End Function

FindDescColumnIndex, GetEquipmentDesciption and GetEquipmentTypeDesciption are helper functions. There are only around 20 rows in the array and the problem is not in these functions.

EDIT: I have included all function code lines for completeness. The function works with 5718 rows and 26 columns in wsData sheet and produces 31,003 rows in the same sheet. Most of the 5718 rows are either desc = "40ft DC or HC" or desc <> desc1 so there are heavy use of insert:

.Cells(i, descColIndx).EntireRow.Offset(1).Resize(2).Insert Shift:=xlDown
.Range(.Cells(i, 1), .Cells(i, lCol)).Copy
.Range(.Cells(i, 1).Offset(1), .Cells(i + 2, lCol)).PasteSpecial Paste:=xlPasteValues

In my opinion, if I can write the above lines in another way, either using Range Union and writing the Range at once at last, the code will be much fast. I am looking for how I can Union the range (for the inserts) and appreciate if someone can provide some pointer.

Thanks

Welcome to Code Review. This question is a bit of a code dump. Please tell us more about the motivation for writing this code, what this code accomplishes, and what the inputs and results are. See How to Ask. — 200_success
– 200_success, Commented Aug 6, 2019 at 5:52
Can you provide some sample data and a "TestWithSampleData" that will call your function? These details will give reviews enough information to verify their own ideas and ensure you're getting good advice. Additionally, if you can provide "stub" routines for GetEquipmentDesc, FindDescColumnIndex, and GetEquipmentType that will make your submission above "complete and verifiable". (Simple returns of static values is just fine, those helper functions don't need to be functional.) — PeterT
– PeterT, Commented Aug 6, 2019 at 20:28

Prakash Gautam · Accepted Answer · 2019-09-09 02:41:03Z

I am going to provide the solution I have found (so that it be helpful for someone) and answers my own question:

The solution is by use of Array and not doing insert, reading and writing cells in the existing sheet. Now the code takes around 35 seconds (to process 5718 rows and create 31,003 rows) instead of 2 minutes, a huge improvement. Important steps are commented in the code below:

With wsData
    .Columns(rateColIndx).Resize(, 2).EntireColumn.Insert 'Bags
    .Cells(1, 11).Value = "carrier_org_id"
    .Cells(1, 15).Value = "Container"
    .Cells(1, 16).Value = "Weight"
    .Cells(1, 17).Value = "Bags"
    .Cells(1, descColIndx).Value = "Descr"
    .Cells(1, rateColIndx).Value = "ratetype"
    .Cells(1, rateColIndx + 1).Value = "equipment_type"
    .Cells(1, rateColIndx + 2).Value = "price"
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    lCol = lCol + 2
    i = 2
    .Range(.Cells(1, 1), .Cells(1, lCol)).Copy
    wsData2.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
    rIndxWsTemp = 2
    'Load all data in a variant Array
    Arr = .Range(.Cells(1, 1), .Cells(lRow, lCol))

    ubArr = UBound(Arr, 1)
    Do While i <= ubArr
        desc = Arr(i, descColIndx)
        desc1 = Arr(i, 18)
        weight2 = Arr(i, 20)
        price = Arr(i, 26)
        bags2 = Arr(i, 21)
        container2 = Arr(i, 19)
        If desc = "40ft DC or HC" Then
            'Do not do insert, reading and writing cells in the existing sheet, instead, use main data array (Arr) and helper/temporary array
            'for reading and writing. Note the Array slicing Arr(i,0)
            ArrTemp = Arr(i, 0)
            'Do processing in a temp array
            ArrTemp1 = ArrTemp
            ArrTemp2 = ArrTemp1
            ArrTemp(1, descColIndx) = desc1
            ArrTemp1(1, descColIndx) = "40ft DC"
            ArrTemp2(1, descColIndx) = "40ft HC"
            ArrTemp1(1, 16) = weight2
            ArrTemp2(1, 16) = weight2
            ArrTemp1(1, 25) = price
            ArrTemp2(1, 25) = price
            ArrTemp(1, rateColIndx) = "ratetype1"
            ArrTemp1(1, rateColIndx) = "ratetype2"
            ArrTemp2(1, rateColIndx) = "ratetype2"
            ArrTemp(1, eqColIndx) = GetEquipmentType(eqDesc, equipments, desc1)
            ArrTemp1(1, eqColIndx) = GetEquipmentType(eqDesc, equipments, "40ft DC")
            ArrTemp2(1, eqColIndx) = GetEquipmentType(eqDesc, equipments, "40ft HC")
            'Use another array ArrComb so that we can write at once to a new sheet
            ReDim ArrComb(1 To 3, 1 To lCol)
            For m = 1 To 1
                For n = 1 To lCol
                    ArrComb(m, n) = ArrTemp(m, n)
                    ArrComb(m + 1, n) = ArrTemp1(m, n)
                    ArrComb(m + 2, n) = ArrTemp2(m, n)
                Next
            Next
            'Write to a new sheet instead of inserting to existing
            With wsData2
                .Range(.Cells(rIndxWsTemp, 1), .Cells(rIndxWsTemp + 2, lCol)).Value = ArrComb
            End With
            rIndxWsTemp = rIndxWsTemp + 3
        ElseIf desc <> desc1 Then
            ArrTemp = .Range(.Cells(i, 1), .Cells(i, lCol)).Value
            ArrTemp1 = ArrTemp
            ArrTemp(1, descColIndx) = desc1
            ArrTemp1(1, 15) = container2
            ArrTemp1(1, 16) = weight2
            ArrTemp1(1, 17) = bags2
            ArrTemp(1, rateColIndx) = "ratetype1"
            ArrTemp1(1, rateColIndx) = "ratetype2"
            ArrTemp(1, eqColIndx) = GetEquipmentType(eqDesc, equipments, desc1)
            ArrTemp1(1, eqColIndx) = GetEquipmentType(eqDesc, equipments, desc)
            ArrTemp1(1, 25) = price
            ReDim ArrComb(1 To 2, 1 To lCol)
            For m = 1 To 1
                For n = 1 To lCol
                    ArrComb(m, n) = ArrTemp(m, n)
                    ArrComb(m + 1, n) = ArrTemp1(m, n)
                Next
            Next
            With wsData2
                .Range(.Cells(rIndxWsTemp, 1), .Cells(rIndxWsTemp + 1, lCol)).Value = ArrComb
            End With
            rIndxWsTemp = rIndxWsTemp + 2
        End If
        i = i + 1
    Loop
End With

Stack Exchange Network

Excel VBA - How to optimize this code with a lot of inserts

1 Answer 1

You must log in to answer this question.

Hot Network Questions

Excel VBA - How to optimize this code with a lot of inserts

1 Answer 1

You must log in to answer this question.

Related

Hot Network Questions