Macro is taking very long time to loop over nearly 700 lines

Question

I am trying to loop over a sheet of nearly 700 lines according to entries of a mapping (index i),each iteration of loop i takes a very long time (long time looping over j) .What can be the cause?I write Macros nearly every day , never experienced this issue. Also I tried to leave only the first line in the loop j , but kept experiencing this issue

The business need : Is to extract all columns in the sheet where Column C contains value that is in the mapping sheet(i.e. satisfying this condition PacketWork = Sheets(sheetname).Cells(j, Column3).Value where column3 is "C"

For i = 2 To lastRowLevelMapping
    PacketWork = Sheets("Mapping").Cells(i, "A").Value
    
    For j = 2 To LastRowSheet

    
    If (PacketWork = Sheets(sheetname).Cells(j, Column3).Value) Then

        Sheets("Source").Cells(writer_counter, "A").Value = Sheets(sheetname).Cells(j, Column1).Value
         
        Sheets("Source").Cells(writer_counter, "B").Value = Sheets(sheetname).Cells(j, Column2).Value
        Sheets("Source").Cells(writer_counter, "C").Value = Sheets(sheetname).Cells(j, Column3).Value
        Sheets("Source").Cells(writer_counter, "D").Value = Sheets(sheetname).Cells(j, Column4).Value
        data = Sheets(sheetname).Cells(j, Column5).Value
        If (IsNumeric(data)) Then
        Sheets("Source").Cells(writer_counter, "E").Value = Round(data, 2)
        Else
            Sheets("Source").Cells(writer_counter, "E").Value = data
        End If

         data = Sheets(sheetname).Cells(j, Column6).Value
         If (IsNumeric(data)) Then
        Sheets("Source").Cells(writer_counter, "F").Value = Round(data, 2)
        Else
             Sheets("Source").Cells(writer_counter, "F").Value = data
        End If
        data = Sheets(sheetname).Cells(j, Column7).Value

         If (IsNumeric(data)) Then
        Sheets("Source").Cells(writer_counter, "G").Value = Round(data, 2)
        Else
            Sheets("Source").Cells(writer_counter, "G").Value = data
        End If
        data = Sheets(sheetname).Cells(j, Column8).Value
         If (IsNumeric(data)) Then
        Sheets("Source").Cells(writer_counter, "H").Value = Round(data, 2)
        Else
            Sheets("Source").Cells(writer_counter, "H").Value = data
        End If
        data = Sheets(sheetname).Cells(j, Column9).Value
        If (IsNumeric(data)) Then
        Sheets("Source").Cells(writer_counter, "I").Value = Round(data, 2)
        Else
            Sheets("Source").Cells(writer_counter, "I").Value = data
        End If

       
       
        If (IsDate(Sheets(sheetname).Cells(j, Column10).Value)) Then
            Sheets("Source").Cells(writer_counter, "P").Value = Format(Sheets(sheetname).Cells(j, Column10).Value, "dd/mm/yyyy")
        Else
             Sheets("Source").Cells(writer_counter, "P").Value = Sheets(sheetname).Cells(j, Column10).Value
        End If
        Sheets("Source").Cells(writer_counter, "P").NumberFormat = "dd/mm/yyyy"
        
        If (Sheets("Source").Cells(writer_counter, "E").Value <> 0) Then


            Sheets("Source").Cells(writer_counter, "L").Value = Round((Sheets("Source").Cells(writer_counter, "F").Value / Sheets("Source").Cells(writer_counter, "E").Value) * 100, 2)
            Sheets("Source").Cells(writer_counter, "M").Value = Round((Sheets("Source").Cells(writer_counter, "G").Value / Sheets("Source").Cells(writer_counter, "E").Value) * 100, 2)

        Else

        Sheets("Source").Cells(writer_counter, "L").Value = 0
        Sheets("Source").Cells(writer_counter, "M").Value = 0

        
        End If
        

        Sheets("Source").Cells(writer_counter, "L").NumberFormat = "0.00"
        Sheets("Source").Cells(writer_counter, "M").NumberFormat = "0.00"

        If (Sheets("Source").Cells(writer_counter, "L").Value > 100) Then

            Sheets("Source").Cells(writer_counter, "L").Value = 100

        End If

        If (Sheets("Source").Cells(writer_counter, "M").Value > 100) Then

            Sheets("Source").Cells(writer_counter, "M").Value = 100

        End If

        If (Contains(Mapping2Collection, Sheets(sheetname).Cells(j, Column4).Value)) Then

                Sheets("Source").Cells(writer_counter, "N").Value = Mapping2Collection(Sheets(sheetname).Cells(j, Column4).Value)

        End If

        Sheets("Source").Cells(writer_counter, "K").Value = Sheets("Mapping").Cells(i, "D").Value
        Sheets("Source").Cells(writer_counter, "J").Value = Sheets("Mapping").Cells(i, "C").Value

        
        Sheets("Source").Cells(writer_counter, "O").Value = Sheets("Mapping").Cells(i, "B").Value
        

         
        writer_counter = writer_counter + 1
        
    


    End If
    Next j
Next i

Nested loops are a code smell here. Consider using `Range.Find` or `Application.Match` instead of looping to find a match. Also consider loading the data into `Variant` arrays and doing all processing in memory, instead of repeatedly referencing the sheet. — BigBen, Apr 05 '21 at 13:54
Setting ```Application.ScreenUpdating = False``` at the beginning and back to ```Application.ScreenUpdating = True``` may speed up things as well. — jf_, Apr 05 '21 at 14:07
You could try [this](https://stackoverflow.com/a/47092175/6600940) — Storax, Apr 05 '21 at 14:18
@Storax that I used this already , but no significant change — Magdy Hafez, Apr 05 '21 at 14:24
@BigBen Can you give me an example about how Can I work on data by copying it in memory not by referencing the sheet according to the code , I will be extremely grateful — Magdy Hafez, Apr 05 '21 at 14:27
[Arrays and ranges](http://www.cpearson.com/excel/ArraysAndRanges.aspx) might be helpful. — BigBen, Apr 05 '21 at 14:28

score 1 · Answer 1 · answered Apr 05 '21 at 15:12

My favourite dictum is "do not work with Excel, work with the data". And you work a lot with Excel - every iteration does a lot of data reading and data entry. Every Sheet.Cells.Value = Sheet.Cells.Value goes to a sheet, a cell and reads a value, then goes to a sheet, another cell and inputs the value there; every condition has to read the cell too. This takes a lot of resources apparently.

In my experience, if you need to do something like this, arrays are the answer. Determine the ranges (Excel objects, which slow you down) you are going to work with, load them into a variant-type variable and then do your operations in the array (data, which you want to really work with, loaded in memory) and then insert the arrays back into the ranges in one go. Illustration: We happened to have a miscommunication at work about some intense data manipulation automation and somebody was duplicating the same automation project, but I did the whole thing using arrays and dictionaries while the other person did it directly through worksheet references. My time per execution is about 30-45 seconds. Theirs is 5-6 hours.

Also if you refer multiple times to the same coordinates, you should really put that into a variable. Not only is it faster again, it is also good coding practice because when you need to modify the code, you do not need to change as many references and minimise the risks of forgetting some.

Thank you very much , Can you help me with how to filter data before inserting into array according to Column C (get a specific value only) Arr = Range(Cells(2, 1), Cells(LastRowSheet, LastCol)) — Magdy Hafez, Apr 05 '21 at 15:39
@MagdyHafez IMO this should not be necessary, hoever if you want to do it, then apply the `Range.Autofilter` and then do `Arr = .Range(.Cells(),.Cells()).SpecialCells(xlCellTypeVisible)` — Eleshar, Apr 05 '21 at 16:05
@MagdyHafez scratch that, can't do that with non contiguous range. Why do you need that filter anyway? — Eleshar, Apr 05 '21 at 16:08
The business need is to make operations on the row if Column C has Specific value — Magdy Hafez, Apr 05 '21 at 16:12
@MagdyHafez That is what your initial ´If´ statement is for, I'd guess. It will just be `If PacketWork = array(j, 3) Then` — Eleshar, Apr 05 '21 at 18:03

score 1 · Accepted Answer · answered Apr 06 '21 at 13:02

Read data into arrays and replace double loop with dictionary look-up

Option Explicit

Sub transform()
    
    Const SHT_INPUT = "sheetname"
    Const SHT_OUTPUT = "Source"
    Const SHT_MAPPING = "Mapping"

    Dim colMap ' mapping for column1 to column10
    colMap = Array(0, 1, 2, 3, 4, 5, 6, 7, 26, 25, 24)

    Dim wb As Workbook
    Dim wsIn As Worksheet, wsMap As Worksheet, wsOut As Worksheet
    Dim arMap(), arIn(), arOut()
    Dim iRowOut As Long, iLastRow As Long, iLastCol As Integer
    Dim c As Integer, i As Long, n As Long, r As Long
    Dim Mapping2Collection As New Collection

    Set wb = ThisWorkbook
    Set wsIn = wb.Sheets(SHT_INPUT)
    Set wsOut = wb.Sheets(SHT_OUTPUT)
    Set wsMap = wb.Sheets(SHT_MAPPING)

    ' build dictionary look up to sheetname column3
    Dim dict As Object, key
    Set dict = CreateObject("Scripting.Dictionary")
    iLastRow = wsIn.Cells(Rows.Count, colMap(3)).End(xlUp).Row 'last row
    iLastCol = wsIn.Cells(1, Columns.Count).End(xlToLeft).Column 'last column
    
    ' copy sheet to array then scan for values in colMap(3)
    arIn = wsIn.Range("A1").Resize(iLastRow, iLastCol).Value2
    For r = 2 To iLastRow
        key = Trim(arIn(r, colMap(3))) ' key in colMap(3)
        If dict.exists(key) Then
            MsgBox "Duplicate key '" & key & "' at row " & r, vbCritical
            Exit Sub
        Else
            dict.Add key, r
        End If
    Next
    MsgBox dict.Count & " records added to dictionary from sheet " & wsIn.Name, vbInformation

    ' copy rows on mapping sheet to array
    iLastRow = wsMap.Cells(Rows.Count, "A").End(xlUp).Row 'last row
    ReDim arMap(iLastRow - 1, 4) ' less header
    arMap = wsMap.Range("A2:D" & iLastRow)

    ' create output
    wsOut.Cells.Clear
    iRowOut = wsOut.Cells(Rows.Count, "A").End(xlUp).Row + 1 'first empty
    n = 0
    For i = 1 To UBound(arMap)
        key = arMap(i, 1) ' col A Packet Work
        Debug.Print i, key
        If dict.exists(key) Then

            ' find row on input sheet matching key
            r = dict(key)
              
            ' build row
            ReDim arOut(1 To 16) ' clear
            ' col A to I
            For c = 1 To 9
                arOut(c) = arIn(r, colMap(c))
            Next

            ' col D to I Round 2 dec if numeric
             For c = 5 To 9
                If IsNumeric(arOut(c)) Then
                    arOut(c) = Round(arOut(c), 2)
                End If
            Next

            'col J K from mappimg sheet
            arOut(10) = arMap(i, 3) ' J = map col C
            arOut(11) = arMap(i, 4) ' K = map col D

            ' col L =F/E and M=G/E % calc
            For c = 12 To 13
               If IsNumeric(arOut(5)) Then
                   If arOut(5) = 0 Then
                      arOut(c) = 0
                   Else
                      arOut(c) = Round(100 * arOut(c - 6) / arOut(5), 2)
                      If arOut(c) > 100 Then arOut(c) = 100
                   End If
               End If
            Next

            ' col N not sure what this is ?
            If contains(Mapping2Collection, arOut(4)) Then
                arOut(14) = Mapping2Collection(arOut(4))
            End If

            'col O from mapping sheet col B
            arOut(15) = arMap(i, 2) ' O = map col B

            ' col P from colMap(10) - date
            arOut(16) = arIn(r, colMap(10)) ' P

            ' format line and write out array
            With wsOut
                 .Cells(iRowOut, "L").NumberFormat = "0.00"
                 .Cells(iRowOut, "M").NumberFormat = "0.00"
                 .Cells(iRowOut, "P").NumberFormat = "dd/mm/yyyy"
                           
                ' write array values to output sheet
                 .Cells(iRowOut, 1).Resize(1, 16) = arOut
            End With
             
            ' next line
            Erase arOut
            iRowOut = iRowOut + 1
            n = n + 1
        End If
    Next
    ' end
    wsOut.Activate
    wsOut.Columns("A:P").AutoFit
    MsgBox n & " rows written to sheet" & wsOut.Name, vbInformation

End Sub

' dummy
Private Function contains(obj As Collection, val) As Boolean
    contains = False
End Function

Yup, that's what I would do, just too lazy to delve into the code so I gave blanket general answer. Also I very much recommend dictionary lookups too, they are lightning fast. — Eleshar, Apr 07 '21 at 12:30

Macro is taking very long time to loop over nearly 700 lines

2 Answers2