Faster way to insert rows and copy data-CodePudding

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

CodePudding user response：

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