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

• 200_success: 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.
• Prakash Gautam: The question has been edited to provide more information.
• PeterT: 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.)

Answer 1

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