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。

试试这个（ 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

除了可能的错误之外，还有两大性能问题

做一个Excel。在您的循环中对所有源行进行..在已经注意到的情况下，它非常慢。
实际上切割和粘贴很多行也很慢。如果您只关心这些值，那么您可以使用范围数组副本，而不是非常快。

我就是这样做的，应该非常快：

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

正如其他人所说，我们无法从您的代码中看出输出行实际上应该放在查询表上，所以我做了一个猜测，但您需要更改它。

VBA：查找功能代码

3 个答案: