VBA : Find function code

Question

I am trying to do vlookup through the find function in vba. I have a list of numbers in loan sheet and property sheet and If the number is found in the loan sheet then it copies the entire row and pastes it in another sheet called query. This is the code I have currently but the code just hangs as I have too many cells to find around 100,000. Any guidance in any errors in the code would be really helpful.

Option Explicit
Sub FindCopy_lall()

Dim calc As Long
Dim Cel As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim rFound As Range
Dim LookRange As Range
Dim CelValue As Variant
 ' Speed
calc = Application.Calculation
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
 'Get Last row of Property SheetColumn
LastRow = Worksheets("Property").Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = Worksheets("Loan").Cells(Rows.Count, "D").End(xlUp).Row

 ' Set range to look in
Set LookRange = Worksheets("Property").Range("E2:E" & LastRow)
 ' Loop on each value (cell)
For Each Cel In LookRange
     ' Get value to find
    CelValue = Cel.Value
     ' Look on IT_Asset
   ' With Worksheets("Loan")
         ' Allow not found error
        On Error Resume Next
        Set rFound = Worksheets("Loan").Range("D2:D" & LastRow2).Find(What:=CelValue, _
         LookIn:=xlValues, _
        Lookat:=xlWhole, MatchCase:=False)
         ' Reset
        On Error GoTo endo
         ' Not found, go next
        If rFound Is Nothing Then
            GoTo nextCel
        Else

           Worksheets("Loan").Range("rFound:rFound").Select
           Selection.Copy
           Worksheets("Query").Range("Cel:Cel").Select
           ActiveSheet.Paste

        End If
    'End With
nextCel:
Next Cel
 'Reset
endo:
With Application
    .Calculation = calc
    .ScreenUpdating = True
End With
End Sub

Answer 1

Running Find() many times in a loop can be very slow - I usually create a lookup using a Dictionary: typically thus is much faster and makes the loop easier to code.

Sub FindCopy_lall()

Dim calc As Long
Dim Cel As Range, LookRange As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim CelValue As Variant
Dim dict As Object

    calc = Application.Calculation

    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    LastRow = Worksheets("Property").Cells(Rows.Count, "E").End(xlUp).Row
    LastRow2 = Worksheets("Loan").Cells(Rows.Count, "D").End(xlUp).Row

    Set dict = RowMap(Worksheets("Loan").Range("D2:D" & LastRow2))

    Set LookRange = Worksheets("Property").Range("E2:E" & LastRow)

    For Each Cel In LookRange
        CelValue = Cel.Value
        If dict.exists(CelValue) Then
           'just copy values (5 cols, resize to suit)
           Cel.Offset(0, 1).Resize(1, 5).Value = _
                 dict(CelValue).Offset(0, 1).Resize(1, 5).Value
            '...or copy the range
            'dict(CelValue).Offset(0, 1).Resize(1, 5).Copy Cel.Offset(0, 1)

        End If
    Next Cel

    With Application
        .Calculation = calc
        .ScreenUpdating = True
    End With
End Sub

'map a range's values to their respective cells
Function RowMap(rng As Range) As Object
Dim rv As Object, c As Range, v
    Set rv = CreateObject("scripting.dictionary")
    For Each c In rng.Cells
        v = c.Value
        If Not rv.exists(v) Then
            rv.Add v, c
        Else
            MsgBox "Duplicate value detected!"
            Exit For
        End If
    Next c
    Set RowMap = rv
End Function

Answer 2

There are many things that needs to be re-written

A) Variables inside the quotes become a string. For example "rFound:rFound" Also you do not need to specify Worksheets("Loan"). before it. It is understood.

You can simply write it as rFound.Select

B) Avoid the Use of .Select It slows down the code. You might want to see this LINK. For example

Worksheets("Loan").Range("rFound:rFound").Select
Selection.Copy
Worksheets("Query").Range("Cel:Cel").Select
ActiveSheet.Paste

The above can be written as

rFound.Copy Cel

Work with Variables/Objects. Try and ignore the use of On Error Resume Next and unnecessary GO TOs if possible.

Try this (UNTESTED)

Option Explicit

Sub FindCopy_lall()
    Dim calc As Long, LrowWsI As Long, LrowWsO As Long
    Dim Cel As Range, rFound As Range, LookRange As Range
    Dim wsI As Worksheet, wsO As Worksheet

    calc = Application.Calculation
    With Application
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    Set wsI = ThisWorkbook.Sheets("Property")
    Set wsO = ThisWorkbook.Sheets("Loan")

    LrowWsI = wsI.Range("E" & wsI.Rows.Count).End(xlUp).Row
    LrowWsO = wsO.Range("D" & wsI.Rows.Count).End(xlUp).Row

    Set LookRange = wsI.Range("E2:E" & LrowWsI)

    For Each Cel In LookRange
        Set rFound = wsO.Range("D2:D" & LrowWsO).Find(What:=Cel.Value, _
                     LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
        If Not rFound Is Nothing Then
           '~~> You original code was overwriting the cel
           '~~> I am writing next to it. Chnage as applicable
           rFound.Copy Cel.Offset(, 1)
        End If
    Next Cel

    With Application
        .Calculation = calc
        .ScreenUpdating = True
    End With
End Sub

Answer 3

Besides the possible bugs the two big performance issues are

1. doing an Excel .Find.. inside your loop over all your source rows, which as has already been noted, is very slow. And

2. actually cutting and pasting a lot of rows is also pretty slow. If you only care about the values, then you can use range-array data copies instead which are very fast.

This is how I would do it, which should be very fast:

Option Explicit
Option Compare Text

Sub FindCopy_lall()

Dim calc As Long, CelValue As Variant
Dim LastRow As Long, LastRow2 As Long, r As Long, sr As Long
Dim LookRange As Range, FindRange As Range, rng As Range
Dim LastLoanCell As Range, LastLoanCol As Long
Dim rowVals() As Variant

 ' Speed
calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'capture the worksheet objects
Dim wsProp As Worksheet: Set wsProp = Worksheets("Property")
Dim wsLoan As Worksheet: Set wsLoan = Worksheets("Loan")
Dim wsQury As Worksheet: Set wsQury = Worksheets("Query")

 'Get Last row of Property SheetColumn
LastRow = wsProp.Cells(Rows.Count, "E").End(xlUp).Row
LastRow2 = wsLoan.Cells(Rows.Count, "D").End(xlUp).Row
Set LastLoanCell = wsLoan.Cells.SpecialCells(xlCellTypeLastCell)
LastLoanCol = LastLoanCell.Column

 ' Set range to look in; And get it's data
Set LookRange = wsProp.Range("E2:E" & LastRow)
Dim Look() As Variant: ReDim Look(2 To LastRow, 1 To 1)
Look = LookRange

 ' Index the source values
Dim colIndex As New Collection
For r = 2 To UBound(Look, 1)
    ' ignore duplicate key errors
    On Error Resume Next
        colIndex.Add r, CStr(CelValue)
    On Error GoTo endo
Next

 'Set the range to search; and get its data
Set FindRange = wsLoan.Range("D2:D" & LastRow2)
Dim Find() As Variant: ReDim Find(2 To LastRow2, 1 To 1)
Find = FindRange

 ' Loop on each value (cell) in the Find range
For r = 2 To UBound(Find, 1)
    'Try to find it in the Look index
    On Error Resume Next
        sr = colIndex(CStr(CelValue))
    If Err.Number = 0 Then

        'was found in index, so copy the row
        On Error GoTo endo
        ' pull the source row values into an array
        Set rng = wsLoan.Range(wsLoan.Cells(r, 1), wsLoan.Cells(r, LastLoanCol))
        ReDim rowVals(1 To rng.Rows.Count, 1 To rng.Columns.Count)
        rowVals = rng
        ' push the values out to the target row
        Set rng = wsQury.Range(wsQury.Cells(sr, 1), wsQury.Cells(sr, LastLoanCol))
        rng = rowVals

    End If
    On Error GoTo endo

Next r

endo:
 'Reset
Application.Calculation = calc
Application.ScreenUpdating = True
End Sub

As others have noted, we cannot tell from your code where the output rows are actually supposed to go on the Query sheet, so I made a guess, but you made need to change that.