Decreasing complexity of loop & Find- VBA I have written the following code; both Sheet 1 and Sheet 2 are rather big sheet with lots of data. Run this Macro is extremely time comsuming ( It has a high complexity I guess). I'm quite new at VBA and therefore having trouble make the code more effective.

Sub Find()

    Dim rgFound As Range
    Dim Index As Long: Index = 6
    Dim Row as Long

    Do While Worksheets("Sheet2").Cells(Index, "D").Value &gt; 0

         Sheets("Sheet1").Select
         Set rgFound = Range("A1:A20000").Find(Worksheets("Sheet2").Cells(Index, "D").Value)

         If Not rgFound Is Nothing Then

            Row = rgFound.Row

            Worksheets("Sheet1").Range("E" &amp; Row).Value = Worksheets("Sheet2").Range("AA" &amp; Index).Value
            Worksheets("Sheet1").Range("F" &amp; Row).Value = Worksheets("Sheet2").Range("AB" &amp; Index).Value
            Worksheets("Sheet1").Range("G" &amp; Row).Value = Worksheets("Sheet2").Range("AC" &amp; Index).Value
            Worksheets("Sheet1").Range("H" &amp; Row).Value = Worksheets("Sheet2").Range("Z" &amp; Index).Value
            Worksheets("Sheet1").Range("J" &amp; Row).Value = Worksheets("Sheet2").Range("AG" &amp; Index).Value
            Worksheets("Sheet1").Range("I" &amp; Row).Value = Worksheets("Sheet2").Range("AD" &amp; Index).Value

        Else
            ' Function // Not done yet
        End If

    Index = Index + 1
    Loop
End Sub


Is the built in Find function effective? The loop loops trough roughly 250-400 values.

Basically, Sheet 2 refers to a specific month. Sheet one contians 12 rows for each employee ( one for each month ). Each Sheet (Sheet2-Sheet13) Have exactly the same format. The values copied from these sheets to Sheet1 are salary, days worked and so forth.
I'll start with the main performance suggestions, but there are a few other issues as well


By far, the most important improvement to be made is to work in memory (arrays, dictionaries)
If moving data to arrays is not possible:


turn off the display, events, calculations, page breaks, etc
use With statements to cache the objects
loops: minimum amount of work necessary, and exit them as soon as possible
one of the few reasons to interact with the ranges is when changing formats for all cells



To illustrate the points I'll provide 2 versions and compare timings


v1 - your code
v2 - screen updating off
v3 - arrays


3 tests each, with 10,000 rows on both sheets:


  v1: 64.164 sec, 40.539 sec, 88.797 sec
  v2: 11.969 sec, 12.055 sec, 11.156 sec
  v3:  0.031 sec,  0.281 sec,  0.033 sec Arrays




Here is Version 2:

Public Sub UpdateData2()
    Dim ws1 As Worksheet, ws2 As Worksheet, r As Long, fr As Long, found As Range, t As Long

    t = Timer
    r = 6
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    With ws2
        Do While .Cells(r, "D").Value &gt; 0
            Set found = ws1.Range("A1:A20000").Find(.Cells(r, "D").Value)
            If Not found Is Nothing Then
                fr = found.Row
                ws1.Range("E" &amp; fr).Value2 = .Range("AA" &amp; r).Value2
                ws1.Range("F" &amp; fr).Value2 = .Range("AB" &amp; r).Value2
                ws1.Range("G" &amp; fr).Value2 = .Range("AC" &amp; r).Value2
                ws1.Range("H" &amp; fr).Value2 = .Range("Z" &amp; r).Value2
                ws1.Range("J" &amp; fr).Value2 = .Range("AG" &amp; r).Value2
                ws1.Range("I" &amp; fr).Value2 = .Range("AD" &amp; r).Value2
            Else
                ' Function // Not done yet
            End If
            r = r + 1
        Loop
    End With
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    Debug.Print "Time: " &amp; Format(Timer - t, "0.000") &amp; " sec"
End Sub




Version 3 (Arrays and Dictionary):


  For dictionaries late binding is slow: CreateObject("Scripting.Dictionary")
  
  Use Early Binding: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime


Public Sub UpdateData3()
    Const FIELDS = 6, MIN_WS2 = 6
    Dim ws1 As Worksheet, ws2 As Worksheet, search1 As Variant, search2 As Variant
    Dim max1 As Long, max2 As Long, ur1 As Variant, ur2 As Variant, uniques As Dictionary
    Dim maps(1 To FIELDS, 1 To 2) As Byte, r As Long, itm As Variant, fld As Long, t As Long

    t = Timer:          Set uniques = New Dictionary
    maps(1, 1) = 5:     maps(1, 2) = 27     'E to AA
    maps(2, 1) = 6:     maps(2, 2) = 28     'F to AB
    maps(3, 1) = 7:     maps(3, 2) = 29     'G to AC
    maps(4, 1) = 8:     maps(4, 2) = 26     'H to Z
    maps(5, 1) = 9:     maps(5, 2) = 30     'I to AD
    maps(6, 1) = 10:    maps(6, 2) = 33     'J to AG
    Set ws1 = ThisWorkbook.Worksheets("Sheet1"):    max1 = ws1.UsedRange.Rows.Count
    Set ws2 = ThisWorkbook.Worksheets("Sheet2"):    max2 = ws2.UsedRange.Rows.Count
    ur1 = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(max1, "J"))
    ur2 = ws2.Range(ws2.Cells(1, "A"), ws2.Cells(max2, "AG"))
    search1 = ws1.Range(ws1.Cells(1, "A"), ws1.Cells(max1, "A"))
    search2 = ws2.Range(ws2.Cells(1, "D"), ws2.Cells(max2, "D"))
    For r = MIN_WS2 To max2
        uniques(Trim$(search2(r, 1))) = r
    Next
    For r = 1 To max1
        itm = Trim$(search1(r, 1))
        If uniques.Exists(itm) Then
            For fld = 1 To FIELDS
                ur1(r, maps(fld, 1)) = ur2(uniques(itm), maps(fld, 2))
            Next
            uniques.Remove itm
        End If
        If uniques.Count = 0 Then Exit For
    Next
    ws1.Range(ws1.Cells(1, "A"), ws1.Cells(max1, "J")) = ur1
    Debug.Print "Rows: " &amp; max1 &amp; "; Time: " &amp; Format(Timer - t, "0.000") &amp; " sec"
End Sub




Other notes related to your code


It's good to qualify references to sheets and ranges, but it's even better to use With statements for performance and maintenance
Select and Activate are almost never needed, and impact performance


Sheets("Sheet1").Select
  Set rgFound = Range("A1:A20000").Find...

should be replaced with Sheets("Sheet1").Range("A1:A20000").Find...


Variable names and sub names like Find, Index, and Row overwrite Excel built-in functions and properties like Sheet1.Row(1), WorkSheet/WorkBook indexes, etc
Make all ranges dynamic, as opposed to Range("A1:A20000") (determine last row and column at run-time)
The Do While loop makes the assumption that a value in column D will never be deleted or empty in the middle of the data
Cells().Value2 is a bit faster than Cells().Value if Currency and Date are not a factor