VBA:查找功能代码

Question

我试图通过vba中的find函数进行vlookup.我在贷款表和财产表中有一个数字列表,如果在贷款表中找到了这个数字,那么它会复制整行并将其粘贴到另一个名为查询的表中.这是我目前的代码,但代码只是挂起,因为我有太多的单元格可以找到大约100,000.对代码中的任何错误的任何指导都会非常有用.

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

在循环中多次运行Find()可能非常慢 - 我通常使用Dictionary创建查找:通常因此更快并且使循环更容易编码.

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