VBA：查找功能代碼

Question

我正在嘗試通過vba中的查找功能來查找vlookup。我在貸款表和屬性表中有一個數字列表，如果在貸款表中找到了這個數字，它會複製整行並將其粘貼到另一個名爲query的表中。這是我目前的代碼，但代碼只是掛起，因爲我有太多的單元格來找到大約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

運行查找（）多次可能會很慢 - 我通常創建使用字典查找：通常這樣的速度要快得多，使循環更容易編碼。

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

有很多事情需要被重新編寫

一個）引號內的變量成爲一個字符串。例如"rFound:rFound"也不需要在它之前指定Worksheets("Loan").。據瞭解。

你可以簡單地寫爲rFound.Select

乙）避免.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

除了可能的錯誤的兩大性能問題

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 

正如其他人所指出的，我們不能從您的代碼說不出哪裏輸出行實際上是應該去上查詢表，所以我做了一個猜測，但你需要改變它。