# 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 > 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" & Row).Value = Worksheets("Sheet2").Range("AA" & Index).Value
Worksheets("Sheet1").Range("F" & Row).Value = Worksheets("Sheet2").Range("AB" & Index).Value
Worksheets("Sheet1").Range("G" & Row).Value = Worksheets("Sheet2").Range("AC" & Index).Value
Worksheets("Sheet1").Range("H" & Row).Value = Worksheets("Sheet2").Range("Z" & Index).Value
Worksheets("Sheet1").Range("J" & Row).Value = Worksheets("Sheet2").Range("AG" & Index).Value
Worksheets("Sheet1").Range("I" & Row).Value = Worksheets("Sheet2").Range("AD" & 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.

• Hi, and welcome to Code Review! Could you give us some more context on what your code is accomplishing? Where is your data, what is it, what problem is your code trying to solve? What's in the specific cells your code is referencing. Does it interact with (e.g.) other formulas in the sheet? The more we know, the more advice we can offer on how to improve it.
– Kaz
Jul 10, 2017 at 14:41
• Would it be faster to just filter sheet1 for the criteria and copy those visible cells to sheet2 range instead of a loop? I use the VBA autofilter a lot for that and it is really fast for me. Jul 10, 2017 at 16:57

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

• 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 > 0
Set found = ws1.Range("A1:A20000").Find(.Cells(r, "D").Value)
fr = found.Row
ws1.Range("E" & fr).Value2 = .Range("AA" & r).Value2
ws1.Range("F" & fr).Value2 = .Range("AB" & r).Value2
ws1.Range("G" & fr).Value2 = .Range("AC" & r).Value2
ws1.Range("H" & fr).Value2 = .Range("Z" & r).Value2
ws1.Range("J" & fr).Value2 = .Range("AG" & r).Value2
ws1.Range("I" & fr).Value2 = .Range("AD" & 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: " & Format(Timer - t, "0.000") & " 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: " & max1 & "; Time: " & Format(Timer - t, "0.000") & " 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