Faster way to insert rows and copy data - excel

Question

I need to find values and test few conditions and insert row into an Excel sheet(file is heavy 65 MB). I have 7 such sheets where I need to insert data. And the reference basedata sheet inside the same file is 75k+ rows(wsSrcREDW)
My code runs really slow. Can someone please suggest faster algorithm. Thanks
Edit: the part that runs really slow is not the array assignments but the insertion of row loop in the end. It takes more than 5 mins to find new accounts and insert information.
Dim Curr() As String
For Each c In wsSrcREDW.Range("J2:J" & lrow1).Cells
ReDim Preserve Curr(2 To c.Row)
Curr(c.Row) = c.Value
Next c
Dim Entity() As String
For Each c In wsSrcREDW.Range("C2:C" & lrow1).Cells
ReDim Preserve Entity(2 To c.Row)
Entity(c.Row) = c.Value
Next c
Dim M9() As String
For Each c In wsSrcREDW.Range("F2:F" & lrow1).Cells
ReDim Preserve M9(2 To c.Row)
M9(c.Row) = c.Value
Next c
''' ECL Wback
Set wsECLWMBB = wbREDWMBB.Sheets("ECL WBack")
lrowECLWOrg = wsECLWMBB.Range("A" & Rows.Count).End(xlUp).Row
Dim I7() As String
For Each c In wsSrcREDW.Range("S2:S" & lrow1).Cells
ReDim Preserve I7(2 To c.Row)
I7(c.Row) = c.Value
Next c
For i = 2 To UBound(I7)
Set c = wsECLWMBB.Range("B2:B" & lrowECLWOrg).Find(I7(i))
If c Is Nothing And Entity(i) = "MIB" Then
lrowECLW = wsECLWMBB.Range("A" & Rows.Count).End(xlUp).Row
wsECLWMBB.Range("A" & (lrowECLW + 1)).EntireRow.Insert
wsECLWMBB.Range("A" & (lrowECLW + 1)).Value = M9(i)
wsECLWMBB.Range("B" & (lrowECLW + 1)).Value = I7(i)
wsECLWMBB.Range("C" & (lrowECLW + 1)).Value = Curr(i)
wsECLWMBB.Range("D" & (lrowECLW + 1)).Formula = "=MID(B" & (lrowECLW + 1) & ",1,7)"
End If
Next i

Answer 1

Use a variant array. Fill it and write the whole array in one operation. The following code should do it.
Option Explicit
Sub TEST()
Dim dataSrcEDW As Variant, dataECLWMBB As Variant, dataNew As Variant
Dim wsSrcREDW As Worksheet, wsECLWMBB As Worksheet
Dim colEntity As Long, colCurr As Long, colM9 As Long, colI7 As Long
Dim iSrcRow As Long, iTargetRow As Long, iNewRow As Long
Dim bFound As Boolean
Dim rgNew As Range
dataSrcEDW = wsSrcREDW.Range("A1").CurrentRegion ' Retrives all the source data
dataECLWMBB = wsECLWMBB.Range("A1").CurrentRegion ' Retrieves all the target data
ReDim dataNew(0, 1 To 4) ' This will contain the new rows you are adding at the end of wsECLWMBB
' Identify the columnns of interest
colCurr = Asc("J") - 64: colEntity = Asc("C") - 64: colM9 = Asc("F") - 64: colI7 = Asc("S") - 64
For iSrcRow = 2 To UBound(dataSrcEDW, 1) ' Scane through the source
bFound = False
If dataSrcEDW(iSrcRow, colEntity) = "MIB" Then
For iTargetRow = 2 To UBound(dataECLWMBB, 1)
If dataSrcEDW(iSrcRow, colI7) = dataECLWMBB(iTargetRow, 2) Then
bFound = True
Exit For
End If
Next
If Not bFound Then ' Check if this is a duplicate add
For iNewRow = 1 To UBound(dataNew, 1)
If dataSrcEDW(iSrcRow, colI7) = dataNew(iNewRow, 2) Then
bFound = True
Exit For
End If
Next
End If
If Not bFound Then
dataNew = AddRowToArray(dataNew)
iNewRow = UBound(dataNew, 1)
dataNew(iNewRow, 1) = dataSrcEDW(iSrcRow, colM9)
dataNew(iNewRow, 2) = dataSrcEDW(iSrcRow, colI7)
dataNew(iNewRow, 3) = dataSrcEDW(iSrcRow, colCurr)
dataNew(iNewRow, 4) = "=MID(B" & UBound(dataECLWMBB, 1) + iNewRow & ",1,7)"
End If
End If
Next
' Write out the new rows
If UBound(dataNew, 1) > 0 Then
Set rgNew = wsECLWMBB.Range("A" & UBound(dataECLWMBB, 1) + 1).Resize(UBound(dataNew, 1), UBound(dataNew, 2))
rgNew = dataNew
End If
End Sub
Public Function AddRowToArray(vArray) As Variant
' Can't do a redim preserve on a multi dimensional array. Add a row manually.
Dim vNewArray As Variant, iRow As Long, iCol As Long
ReDim vNewArray(1 To UBound(vArray, 1) + 1, 1 To UBound(vArray, 2))
For iRow = 1 To UBound(vArray, 1)
For iCol = 1 To UBound(vArray, 2)
vNewArray(iRow, iCol) = vArray(iRow, iCol)
Next
Next
AddRowToArray = vNewArray
End Function