3
\$\begingroup\$

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.

\$\endgroup\$
  • 2
    \$\begingroup\$ 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. \$\endgroup\$ – Kaz Jul 10 '17 at 14:41
  • \$\begingroup\$ 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. \$\endgroup\$ – Ashton Morgan Jul 10 '17 at 16:57
1
\$\begingroup\$

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 > 0
            Set found = ws1.Range("A1:A20000").Find(.Cells(r, "D").Value)
            If Not found Is Nothing Then
                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
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.