Excel 2010 VBA - How to optimize this code so it doesn't lag out?

Question

I'm new to VBA and I have recently been creating a few macros. I currently have one that works, but it isn't very cooperative at times. I've done a bunch of reading on how to optimize VBA code, but I'm still not getting very far. I understand using Select is bad, and I've removed as much of the Select lines as I could on my own. I've also read that many if statements combined with loops can be hard to run as well (of course I have multiples of both).

So I know some of the reasons why my code is bad, but I don't really know how to fix it. I added

    Application.ScreenUpdating = False
    Application.ScreenUpdating = True

to my macro as well. This has helped, but not much. I have other macros that can run for a long time and never freeze up. This macro freezes if it doesn't finish in 10-15 seconds. If I only have a couple 100 rows of data it runs no problem. If I have a few 1000 lines of data it doesn't finish before it freezes.

Option Explicit

Sub FillGainerPrices()

    Application.ScreenUpdating = False
    'Search each name on "Gainer Prices" and if the same name is on "Gainers", but not on Gainer Prices _
move it over to Gainer Prices tab.  Then call Historical Query and Fill Names

Dim LastRow1 As Long
LastRow1 = Sheets("Gainers").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim LastRow2 As Long
LastRow2 = Sheets("Gainer Prices").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim Name1 As Range
Dim Name2 As Range
For Each Name1 In Sheets("Gainers").Range("B2:B" & LastRow1)
    Set Name2 = Sheets("Gainer Prices").Range("A2:A" & LastRow2).Find(Name1, LookIn:=xlValues, LookAt:=xlWhole)
    If Name2 Is Nothing Then
        If Name1.Offset(0, -1) < Date - 15 Then
            Name1.Copy
            Sheets("Gainer Prices").Select
            Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).Select
            ActiveSheet.Paste
            Call HistoricalQuery
        End If
    End If
Next Name1
Application.ScreenUpdating = True

'Fill in Names and remaining symbols here
Call FillNamesAndSymbols

End Sub

Call HistoricalQuery and Call FillNamesAndSybmols are pretty quick and do not seem to have any issues when I run them by themselves so I don't think they are causing the problem. I'm guessing the issue is searching for one Name 1000's of times and then copying and pasting over and over, but I can't figure out how to get rid of the copy and paste part without the macro giving me wrong results.

The end goal of the macro is to go to the 2nd sheet and see if those names are on the first sheet. If not, it moves the names over, and then for each name it moves over it calls another macro to pull historical data for that name. Finally at the end it just does some formatting and filling in or deleting of blank cells. If anyone can direct me in the correct direction I would appreciate it. Thanks!

Answer 1

Try this code.

Improvments:

• Timing: my code: 0.8828125 sec, your code: 10.003 sec. (tested with 1000 rows in both sheets)
• I'm using array to store values from second sheet: arr = Sheets("Gainer Prices").Range("A2:A" & LastRow2).Value - much faster for huge data
• I'm using Application.Match instead Range.Find - it's faster as well.
• I'm using Range(..).Value = Range(..).Value instead copy/paste
• avoid using select/active statement

---

Sub FillGainerPrices()
    Dim LastRow1 As Long
    Dim LastRow2 As Long
    Dim Lastrow3 As Long

    Dim Name1 As Range

    Dim sh1 As Worksheet
    Dim sh2 As Worksheet

    Dim arr As Variant
    'remember start time
    Dim start as Long
    start = Timer

    Application.ScreenUpdating = False

    Set sh1 = ThisWorkbook.Sheets("Gainers")
    Set sh2 = ThisWorkbook.Sheets("Gainer Prices")

    With sh1
        LastRow1 = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With
    With sh2
        LastRow2 = .Cells(.Rows.Count, "A").End(xlUp).Row  
        arr = .Range("A2:A" & LastRow2).Value          
    End With

    For Each Name1 In sh1.Range("B2:B" & LastRow1)
        If IsError(Application.Match(Name1.Value, arr, 0)) Then
            If Name1.Offset(0, -1) < Date - 15 Then
                With sh2
                    Lastrow3 = .Cells(.Rows.Count, "C").End(xlUp).Row
                    .Range("A" & Lastrow3 + 1).Value = Name1.Value
                End With

                Call HistoricalQuery
            End If
        End If
    Next Name1

    'Fill in Names and remaining symbols here
    Call FillNamesAndSymbols

    Application.ScreenUpdating = True
    'To see timing result press CTRL+G in the VBE window, or change Debug.Print to MsgBox
    Debug.Print "Code evaluates for: " & Timer - start
End Sub

Answer 2

instead of

Name1.Copy
Sheets("Gainer Prices").Select
Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).Select
ActiveSheet.Paste

you might try something like this:

Name1.copy destination:=Sheets("Gainer Prices").Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2)

or perhaps

Sheets("Gainer Prices").Range("C" & Cells.Rows.Count).End(xlUp).Offset(1, -2).value=Name1.value