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

ループ内で 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
于 2013-04-26T16:09:44.140 に答える
0

考えられるバグに加えて、2 つの大きなパフォーマンスの問題は次のとおりです。

  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 に答える