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

Answer 2

有很多事情需要重写

A ）引号内的变量变为字符串。 例如， "rFound:rFound"也不需要指定Worksheets("Loan"). 在它之前。 据了解。

您可以简单地将其编写为rFound.Select

B ）避免使用.Select会减慢代码速度。 您可能需要查看此LINK 。 例如

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

上面可以写成

rFound.Copy Cel

使用变量/对象。 如果可能的话，请尝试不要使用On Error Resume Next和不必要的GO TOs 。

试试这个（ 未经测试 ）

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

除了可能的错误外，两个主要的性能问题是

1. 在所有源行的循环中执行Excel .Find ..的过程非常缓慢，这已经注意到。 和

2. 实际上，剪切和粘贴很多行也很慢。 如果只关心这些值，则可以使用范围数组数据副本，它们非常快。

这就是我的方法，应该很快：

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

正如其他人指出的那样，我们无法从您的代码中得知输出行实际上应放在查询表中的哪个位置，因此我做出了一个猜测，但您需要更改它。