2

問題：特定のポリシー番号を探すために大きなシートを検索する必要があります。75,000行近くある場合、検索機能にはかなりの時間がかかります。これらの75,000行の2枚のシートを比較する方法について何か提案はありますか？私がうまくいくと思った解決策は、各シートを並べ替えてから、見つける必要のあるポリシー番号を取得して、それを中央の行と比較することです。そのポリシー番号を比較して、単純な並べ替え関数でそれが大きいか小さいかを確認する方法はありますか？その比較を見つけた後、私は上限と下限をリセットし、再び中間を見つけます。...これはもっと速いでしょうか？他に何か提案はありますか？

ありがとうございました

現在のコード：

Sub policyComment()

Dim x As Integer
Dim endRow As Variant
Dim polSer As String
Dim foundVal As String
Dim commentVar As Variant        

Windows("SuspenseNoteMacro.xlsm").Activate
Sheets("Main").Select

Range("A2").Select
endRow = ActiveCell.End(xlDown)

x = 2

Do
    polSer = Range("A" + CStr(x)).Value

    Windows("010713 Suspense ALL.xlsm").Activate
    Sheets("Sheet1").Select

    Set foundRange = Sheets("Sheet1").Cells.Find(what:=polSer, LookIn:=xlFormulas, lookat:=xlWhole)

   'foundRange = ActiveCell.Value     
    If foundRange Is Nothing Then
        Windows("SuspenseNoteMacro.xlsm").Activate
        Sheets("Main").Select
        Range("J" + CStr(x)).Value = "Not Found"
    ElseIf foundRange <> "" Then
        Sheets("Sheet1").Cells.Find(what:=polSer, LookIn:=xlFormulas, lookat:=xlWhole).Activate
        commentVar = Range("J" + CStr(ActiveCell.Row)).Value
        Windows("SuspenseNoteMacro.xlsm").Activate
        Sheets("Main").Select
        Range("J" + CStr(x)).Value = commentVar
    End If

    x = x + 1
    Range("A" + CStr(x)).Select
    foundRange = ""
Loop Until (x = endRow)

End Sub
4

2 に答える 2

4

Scott は既に回答を提供していますが、参考までに、Find() を使用する場合と Dictionary を使用して同じ 10k の値を含むソートされていない範囲内の 10k の個別の値を検索する場合の違いを示すサンプル コードをいくつか示します。

私のPCでの出力：

50.48828 sec using Find()
0.078125 sec to load dictionary (10000 keys)
0.015625 sec using Dictionary

コード (「Microsoft Scripting Runtime」ライブラリへの参照が必要):

Sub TestFind()

    Dim arrToFind
    Dim numRows As Long, r As Long
    Dim f As Range, rngSrc As Range
    Dim t
    Dim d As Scripting.Dictionary

    Set rngSrc = Worksheets("Source").Range("A2:A10001")

    arrToFind = Worksheets("Dest").Range("A2:A10001").Value
    numRows = UBound(arrToFind, 1)

    t = Timer
    Debug.Print "Starting test using Find()"
    For r = 1 To numRows
        If r Mod 1000 = 0 Then Debug.Print "Row " & r
        Set f = rngSrc.Find(arrToFind(r, 1), , xlValues, xlWhole)
        If Not f Is Nothing Then
        'do something based on f
        End If
    Next r
    Debug.Print Timer - t & " sec using Find()"

    t = Timer
    Set d = UniquesFromRange(rngSrc)
    Debug.Print Timer - t & " sec to load dictionary (" & d.Count & " keys)"

    t = Timer
    Debug.Print "Starting test using Dictionary"
    For r = 1 To numRows
        If r Mod 1000 = 0 Then Debug.Print "Row " & r
        If d.Exists(arrToFind(r, 1)) Then
        'use value from dictionary
        End If
    Next r
    Debug.Print Timer - t & " sec using Dictionary"

End Sub

Function UniquesFromRange(rng As Range) As Scripting.Dictionary

    Dim d As New Scripting.Dictionary
    Dim c As Range, tmp

    For Each c In rng.Cells
       tmp = Trim(c.Value)
       If Len(tmp) > 0 Then
            If Not d.Exists(tmp) Then d.Add tmp, c.Offset(0, 1).Value
       End If
    Next c

    Set UniquesFromRange = d
 End Function
于 2013-01-10T22:53:38.227 に答える
3

コードが遅いのにはいくつかの理由がありますが、主に各セルを個別にループしていることが原因です (実際のFind関数が遅くしているのではありません)。

以下では、検索列を配列に入れ、それをループ処理しました。これにより、はるかに高速になります。また、VBA では 99% の確率で無関係であり、コードの速度が少し低下する可能性があるため、すべてのselectandステートメントも削除しました。activate最後に、私もオフにしScreenUpdatingました。

リファクタリングで何かを見逃した場合は、お知らせください。

Option Explicit

Sub policyComment()

Dim x As Long, endRow As Long, polSer As String, foundRange As range, commentVar As String
Dim varArr() As Variant
Dim wksMain As Worksheet, wks1 As Worksheet

Set wksMain = Sheets("Main")
Set wks1 = Sheets("Sheet1")

Application.ScreenUpdating = False

With wksMain

    endRow = .range("A" & .Rows.Count).End(xlUp).Row
    varArr = .range("A2:A" & endRow)

    For x = LBound(varArr) To UBound(varArr)

        polSer = varArr(x, 1)

        With wks1

            Set foundRange = .Cells.Find(polSer, LookIn:=xlFormulas, lookat:=xlWhole)

            If foundRange Is Nothing Then

                wksMain.range("J" & x + 1).Value = "Not Found" 'need to add 1 to x because arrays are zero based

            Else

                commentVar = .range("J" & foundRange.Row)
                wksMain.range("J" & x + 1).Value = commentVar ''need to add 1 to x because arrays are zero based

            End If

        End With

    Next

End With

Application.ScreenUpdating = True

End Sub
于 2013-01-10T20:16:30.793 に答える