1

我正在尝试通过 vba 中的查找功能进行 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
4

3 回答 3

6

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
于 2013-04-26T16:09:44.140 回答
0

有很多东西需要重写

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

你可以简单地把它写成rFound.Select

B）避免使用.Select它会减慢代码的速度。您可能想查看此链接。例如

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
于 2013-04-26T16:12:46.227 回答
0

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

  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

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

于 2013-04-26T16:46:01.187 回答