.Find VBA taking a long time to execute across two worksheets

Question

I'm using VBA to loop through rows on two worksheets and if they match, copy the row from sheet 2 into sheet 1.

My code is supposed to:

• Opens a second workbook
• Copies all info into original workbook on new sheet
• A loop then goes through column F on original Sheet (450+rows) and finds the activecell on new "data" sheet (9,500+rows), upon finding the same value it copies the entire row and pastes it into original sheet then loop starts again.

Although this does work, I'm finding that this takes in excess of 20 minutes, which is way too long! I'm a beginner to VBA and although I've made good progress I'm stuck with this, I've read up on Variants but they're confusing me to be honest! Any help would be appreciated :)

Sub AutoUpdate()
    'Opens Enterprise Master Lead File (whichever is present) and auto updates data
    ' in current sheet depending on if ID ref is present

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    'This opens the workbook without setting set date as long as the
    'file is always in the same place

    Dim Wb As Workbook
    Dim Wb2 As Workbook
    Dim rng As Range, Cel As Range
    Dim sFind As String
    Dim lastRow As Long

    lastRow = Range("F" & Rows.Count).End(xlUp).Row
    Set rng = Range("F2:F" & lastRow)

    Set Wb = ThisWorkbook
   
    Set Wb2 = Workbooks.Open("xxxxxxxxxxx.xlsx") 'opens secondary workbook

    'Deletes unecessary columns
      
    Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Select
    Selection.Delete Shift:=xlToLeft
    
    Range("A2").Select
                    
    Cells.Select
    Selection.Copy
    
    Wb.Activate
    Sheets.Add.Name = "Data"
    Range("A1").Select
    ActiveSheet.Paste
    Wb2.Close 'closes secondary workbook to speed up process
    Wb.Activate
    
    'Loop - finds data in original sheet, finds data in secondary
    'sheet, copies new data and pastes, offsets and starts again
 
    Sheets("Corp Leads").Activate
 
    With Wb
        rng.Select
        'Range("F1").Select
        'ActiveCell.Offset(1, 0).Select
        'Range(Selection, Selection.End(xlDown)).Select
        For Each Cel In rng
            If Cel.Value > 0 Then
                ActiveCell.Select
                sFind = ActiveCell
                                                                                                        
                'Finding matching data
                Sheets("Data").Activate
                Range("F2").Select
                Range(Selection, Selection.End(xlDown)).Select
                Cells.Find(What:=sFind, After:= _
                    ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False).Activate
                ActiveCell.Select

                'copying new data row
                ActiveCell.EntireRow.Select
                Selection.Copy
                    
                'Finding same data again in original sheet
                Sheets("Corp Leads").Activate
                Cells.Find(What:=sFind, After:= _
                    ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False).Activate
                ActiveCell.Select
                
                'Pasting new data
                ActiveCell.EntireRow.PasteSpecial Paste:=xlPasteValues
                Application.CutCopyMode = False
                
                'Finding reference again to offset for loop
                Cells.Find(What:=sFind, After:= _
                    ActiveCell, LookIn:=xlFormulas, _
                    LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False).Activate
                ActiveCell.Select
                ActiveCell.Offset(1, 0).Select
            End If
        Next Cel
    End With
    Sheets("Data").Delete
    MsgBox ("UPDATED")
End Sub

Answer 1

Like I mentioned in the comments, It is not the .Find which is taking so long. It is the use of .Select/.Activate etc which is slowing down your code. You may want to see How to avoid using Select in Excel VBA

This code is the non array version. See how I avoided the use of .Select/.Activate?

Option Explicit

Sub Sample()
    Dim wbThis As Workbook: Set wbThis = ThisWorkbook
    Dim wbThat As Workbook
    
    '~~> Change this to the relevant worksheet
    Dim wsThis As Worksheet: Set wsThis = wbThis.Sheets("Corp Leads")
    Dim wsNewThis As Worksheet
    Dim wsThat As Worksheet
    
    '~~> Add the data sheet if required
    On Error Resume Next
    Set wsNewThis = wbThis.Sheets("Data")
    On Error GoTo 0
    If wsNewThis Is Nothing Then
        wbThis.Sheets.Add.Name = "Data"
    Else
        wsNewThis.Cells.Clear
    End If

    '~~> Open the relvant workbook
    Set wbThat = Workbooks.Open("xxxxxxxxxxx.xlsx")
    Set wsThat = wbThat.Sheets("RelevantSheetName") 

    Dim lastRow As Long
    Dim lastCol As Long
    
    With wsThat
        .Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD").Delete
        
        If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
            lastRow = .Cells.Find(What:="*", _
                       After:=.Range("A1"), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
    
            lastCol = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByColumns, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Column
        Else
            lastRow = 1: lastCol = 1
        End If
                   
        .Range(.Cells(1, 1), .Cells(lastRow, lastCol)).Copy wsNewThis.Range("A1")
        DoEvents
        .Close (False)
    End With

    Dim aCell As Range
    
    With wsThis
        lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
        For i = lastRow To 2 Step -1
            If .Range("F" & i).Value2 > 0 Then
                Set aCell = wsNewThis.Columns(6).Find(What:=.Range("F" & i).Value2, _
                            LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                            SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
     
                If Not aCell Is Nothing Then
                    .Rows(i + 1).Insert
                    wsNewThis.Rows(aCell.Row).Copy .Rows(i + 1)
                End If
            End If
        Next i
    End With
    
    Application.DisplayAlerts = False
    wsNewThis.Delete
    Application.DisplayAlerts = True
End Sub

Answer 2

Here's a version using arrays a dictionary lookup, which can be faster than a loop with Find()

Sub Update()

    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws
    Dim wsdata As Worksheet, wsImport As Worksheet
    Dim dict As Object, k, i As Long, m, arrF
    
    '~~> Change this to the relevant worksheet
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("Worksheet1")
    Set ws2 = wb1.Sheets("Worksheet2")
    
    On Error GoTo haveError
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".xlsx") 'opens secondary workbook
    Set wsdata = wb2.Sheets(1)                          'for example, or use name if known
    wsdata.Range("C:D,G:K,M:Q,S:S,U:W,Z:Z,AD:AD").Delete 'Delete unecessary columns
    
    'create a lookup on ColF in data source and map to row number
    Set dict = CreateObject("scripting.dictionary")
    '   get data into an array (1 to #rows, 1 to #cols)
    arrF = wsdata.Range("F1:F" & wsdata.Cells(Rows.Count, "F").End(xlUp).Row).Value
    For i = 2 To UBound(arrF)      'loop over the array; exclude header
        dict(arrF(i, 1)) = i         'maps row number to value
    Next i
    
    For Each ws In Array(ws1, ws2) 'update each sheet in turn
        arrF = ws.Range("F1:F" & ws.Cells(ws.Rows.Count, "F").End(xlUp).Row).Value
        For i = 2 To UBound(arrF)  'exclude header
            k = arrF(i, 1)
            If k > 0 Then
                If dict.exists(k) Then
                    ws.Rows(i).Value = wsdata.Rows(dict(k)).Value 'faster
                    'wsdata.Rows(dict(k)).Copy ws.Cells(i, 1)
                End If
            End If
        Next i
    Next ws

    'wb2.Close False 'don't save changes

    MsgBox "UPDATED"
haveError:
    Application.Calculation = xlCalculationAutomatic

End Sub

Answer 3

So with the help from Siddharth (comments) I came up with some code that works nad completes the queries in under a minute for not one but two separate sheets, which is the whole task!

Still using some .select statements which I know is naughty but it still performs really well. Happy to update with any further suggestions, found engaging with the comments very helpful today! :)

Might not be the neatest code but it works!

Sub Update()

Application.DisplayAlerts = False Application.ScreenUpdating = False

Dim wb1 As Workbook: Set wb1 = ThisWorkbook
Dim wb2 As Workbook

'~~> Change this to the relevant worksheet
Dim ws1 As Worksheet: Set ws1 = wb1.Sheets("Worksheet1")
Dim ws2 As Worksheet: Set ws2 = wb1.Sheets("Worksheet2")
Dim wsdata As Worksheet
   

Dim lastRow As Long
Dim lastCol As Long

   Set wb1 = ThisWorkbook
    
    Set wb2 = Workbooks.Open("xxxxxxxxxxxx*" & ".xlsx") 'opens secondary workbook


 'Deletes unecessary columns
  
                Range("C:C,D:D,G:G,H:H,I:I,J:J,K:K,M:M,N:N,O:O,P:P,Q:Q,S:S,U:U,V:V,W:W,Z:Z,AD:AD"). _
                Select
                Selection.Delete Shift:=xlToLeft

                Range("A2").Select
                
                Cells.Select
                Selection.Copy

wb1.Activate
Sheets.Add.Name = "Data"
Range("A1").Select
ActiveSheet.Paste
wb2.Close 'closes secondary workbook to speed up process
wb1.Activate


Dim aCell As Range
Dim i As Long
Set wsdata = wb1.Sheets("Data")

'Finds matching values (externel ref ID) using Corp Leads and Data sheets

With ws1
    lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
    For i = lastRow To 2 Step -1
        If .Range("F" & i).Value2 > 0 Then
            Set aCell = wsdata.Columns(6).Find(What:=.Range("F" & i).Value2, _
                        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            
            
            'inserts updated rows into corp leads sheet
            
            If Not aCell Is Nothing Then
                wsdata.Rows(aCell.Row).Copy .Rows(i)
            End If
        End If
    Next i
End With



With ws2
        lastRow = .Range("F" & .Rows.Count).End(xlUp).Row
    For i = lastRow To 2 Step -1
        If .Range("F" & i).Value2 > 0 Then
            Set aCell = wsdata.Columns(6).Find(What:=.Range("F" & i).Value2, _
                        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If Not aCell Is Nothing Then
                wsdata.Rows(aCell.Row).Copy .Rows(i)
            End If
        End If
    Next i
End With

wsdata.Delete
Application.DisplayAlerts = True

 MsgBox "UPDATED"

 End Sub