vba - Excel VBA - 1 つのワークブックの列を反復処理し、対応するワークブックに情報を貼り付けます

Question

あるワークブックに現在のデータがあり、別のワークブックにアーカイブデータがあります。最近のデータワークブックの列 "B" には、ID 変数があります。私は言いたい：

最近のデータの列 B の ID ごとに、アーカイブされたワークブックの列 A のすべての行を反復処理します。一致する場合は、最近のデータワークブックのさまざまな列エントリをアーカイブ済みワークブックにコピーします。

動作するコードを書きましたが、問題は、アーカイブデータワークブックに 1,048,575 行あるため、一致ごとに For ループの実行が非常に遅くなることです。これについて考えるより良い方法はありますか？

これが私の現在のコードです：

Sub CopyDataLines()
    Dim wb As Workbook, wb2 As Workbook
    Dim ws As Worksheet
    Dim vFile As Variant
    Dim Filter As String
    Dim FilterIndex As Integer
    Dim Pupid As String

    'Set source workbook
    Set wb = ActiveWorkbook
    Set wbSheet = ActiveSheet

    'Filters for allowed files
    Filter = "Excel Later Versions (*.xlsx),*.xlsx," & _
             "Excel Files (*.xls),*.xls,"

    FilterIndex = 1

    'Open the target workbook
    vFile = Application.GetOpenFilename(Filter, FilterIndex, "Select One File to Open", , False)

    'if the user didn't select a file, exit sub
    If TypeName(vFile) = "Boolean" Then Exit Sub

    'Else open the file
    Workbooks.Open vFile

    'Set worbook to copy from
    Set wb2 = ActiveWorkbook
    Set wb2sheet = ActiveSheet

    With wb2.ActiveSheet
        FirstRow_book2 = 3
        LastRow_book2 = .Cells(.Rows.Count, "B").End(xlUp).Row

        'The contents of the tracking book
        FirstRow_book1 = 3
        LastRow_book1 = wbSheet.Cells(.Rows.Count, "A").End(xlUp).Row

        For Lrow = LastRow_book2 To FirstRow_book2 Step -1
            With .Cells(Lrow, "B")
                 Pupid = .Value
            End With

            'The For Loop Now Iterates Through All of the First WorkBook
            For Lrow_book1 = LastRow_book1 To FirstRow_book1 Step -1
                With wbSheet.Cells(Lrow_book1, "A")
                    If .Value = Pupid Then

                        'Reference for Date Changed Cells
                         wbSheet.Cells(Lrow_book1, "V") = wb2sheet.Cells(Lrow, "C")

                        'Reference for Date Changed Cells
                         wbSheet.Cells(Lrow_book1, "X") = wb2sheet.Cells(Lrow, "D")

                         'Prepare to copy range of multiple columns
                        Let secondBookRange = "I" & Lrow & ":" & "N" & Lrow
                        Let firstBookRange = "AI" & Lrow_book1 & ":" & "AN" & Lrow_book1

                        wb2sheet.Range(secondBookRange).Copy Destination:=wbSheet.Range(firstBookRange)


                    End If
                End With
            Next Lrow_book1
        Next Lrow
    End With

ディクショナリ/ハッシュマップを使用した現在の実装:

Sub CopyLinesImproves()
    Dim vFile As Variant
    Dim Filter As String
    Dim FilterIndex As Integer
    Dim Pupid As Long

    'Set Tracking Book
    Set wb_TrackingBook = ActiveWorkbook
    Set wbSheet_TrackingBook = ActiveSheet

    'Set Last Row of TrackingBook
    LastRow_TrackingBook = wbSheet_TrackingBook.Cells(wbSheet_TrackingBook.Rows.Count, "A").End(xlUp).Row

    'Filters for allowed files
    Filter = "Excel Later Versions (*.xlsx),*.xlsx," & _
             "Excel Files (*.xls),*.xls,"

    FilterIndex = 1

    'Open the target workbook
    vFile = Application.GetOpenFilename(Filter, FilterIndex, "Select One File to Open", , False)

    'if the user didn't select a file, exit sub
    If TypeName(vFile) = "Boolean" Then Exit Sub

    'Else open the file
    Set wb_NewData = Workbooks.Open(vFile)
    Set wbSheet_NewData = wb_NewData.ActiveSheet

    'Set First Row and Last Row of the New Data Worksheet
    FirstRow_NewData = 3
    LastRow_NewData = wbSheet_NewData.Cells(wbSheet_NewData.Rows.Count, "B").End(xlUp).Row

    'create a lookup map using a dictionary
    Set rngLookup = wbSheet_TrackingBook.Range("A1").Resize(LastRow_TrackingBook, 1)
    Set d = GetMap(rngLookup)


    For CurrentRow = FirstRow_NewData To LastRow_NewData Step 1
        Pupid = wbSheet_NewData.Cells(CurrentRow, "B").Value
        If d.exists(Pupid) Then

            wbSheet_TrackingBook.Cells(d(Pupid), "V") = wbSheet_NewData.Cells(CurrentRow, "C")
            wbSheet_TrackingBook.Cells(d(Pupid), "X") = wbSheet_NewData.Cells(CurrentRow, "D")


            Let secondBookRange = "I" & CurrentRow & ":" & "N" & CurrentRow
            Let firstBookRange = "AI" & d(Pupid) & ":" & "AN" & d(Pupid)

            wbSheet_NewData.Range(secondBookRange).Copy Destination:=wbSheet_TrackingBook.Range(firstBookRange)

        End If
    Next CurrentRow

End Sub
Function GetMap(rng) As Object
    Dim d, v, arr, ub As Long, r As Long, r1 As Long
    Dim c As Range
    Set d = CreateObject("scripting.dictionary")
    arr = rng.Value
    r1 = rng.Cells(1).Row
    ub = UBound(arr, 1)
    For r = 1 To ub
        v = arr(r, 1)
        If Len(v) > 0 Then
            If d.exists(v) Then
                d(v) = d(v) & "|" & r1 + (r - 1)
            Else
                d.Add v, r1 + (r - 1)
            End If
        End If
    Next r
    Set GetMap = d
End Function

score 12 · Accepted Answer

セルをループしたり、を使用して広い範囲でルックアップを繰り返し実行すると、Find()非常に遅くなる可能性があります。検索される行の数と実行するルックアップの数 (およびルックアップ範囲で ID を繰り返すことができるかどうか) に応じて、(たとえば) を使用してルックアップデータの「マップ」を作成するなど、いくつかのオプションがあります。辞書、または使用MATCH()。

いくつかの異なる方法を説明するためのコード (以下) を次に示します。1 から 1048535 までのランダムな数値を含むルックアップ列を作成し、さまざまな方法を使用して、さまざまなサイズの範囲でさまざまな数のルックアップを実行しました。

100k 値の範囲で 100 または 1000 のルックアップを実行した場合の出力例:

EDIT：収集方法を追加しました（Sidに感謝）

#### Searching: 100000      # lookups: 100
Loop          Map: 0        Lookup: 14.777              Total: 14.777
Loop (array)  Map: 0        Lookup: 0.711               Total: 0.711
Find          Map: 0        Lookup: 8.762               Total: 8.762
Dictionary    Map: 0.73     Lookup: 0.00391             Total: 0.73391
Collection    Map: 0.723    Lookup: 0                   Total: 0.723
Match         Map: 0        Lookup: 0.145               Total: 0.145



#### Searching: 100000      # lookups: 1000
Loop          Map: 0        Lookup: 150.984             Total: 150.984
Loop (array)  Map: 0        Lookup: 6.465               Total: 6.465
Find          Map: 0        Lookup: 82.527              Total: 82.527
Dictionary    Map: 0.602    Lookup: 0.00781             Total: 0.60981
Collection    Map: 0.672    Lookup: 0.00781             Total: 0.67981
Match         Map: 0        Lookup: 1.359               Total: 1.359

基本的な「セルをその場でループする」アプローチは、テストした方法の中で最も遅い方法です。代わりに、ルックアップ範囲から抽出された配列をループすることで、このアプローチを 10 倍以上改善できます。

Find()一貫して遅く (基本的なループアプローチの約 2 倍の速度しかありません)、大規模なルックアップの場合は非常に遅くなります。Match()100 回のルックアップではディクショナリ/コレクションアプローチよりも優れていますが、「マップ」のオーバーヘッドはルックアップ範囲のサイズのみに依存し、各「ルックアップ」操作は非常に高速であるため、辞書とコレクションのアプローチはより多くのルックアップに適しています。 ..

コード：

Option Explicit

Sub SpeedTests()
    Const NUM_ROWS As Long = 100000 
    Const NUM_IDS As Long = 1000
    Dim rngLookup As Range, f As Range
    Dim d, d2, t, l As Long, v, t1, t2
    Dim arr, c As Range, ub As Long, rw As Long

    Set rngLookup = ActiveSheet.Range("A1").Resize(NUM_ROWS, 1)

    Debug.Print "#### Searching: " & NUM_ROWS, "# lookups: " & NUM_IDS

    'basic loop
    t = Timer
    For l = 1 To NUM_IDS
        For Each c In rngLookup.Cells
            If c.Value = l Then
            'found
            End If
        Next c
    Next l
    t2 = Round(Timer - t, 3)
    t1 = 0
    Debug.Print "Loop", "Map: 0", "Lookup: " & t2, "Total: " & (t1 + t2)

    'loop on array
    t = Timer
    arr = rngLookup.Value
    t1 = Round(Timer - t, 3)
    ub = UBound(arr, 1)
    For l = 1 To NUM_IDS
        For rw = 1 To ub
            If arr(rw, 1) = l Then
            'found
            End If
        Next rw
    Next l
    t2 = Round(Timer - t, 3)
    t1 = 0
    Debug.Print "Loop (array)", "Map: 0", "Lookup: " & t2, "Total: " & (t1 + t2)

    'regular use of Find()
    t = Timer
    For l = 1 To NUM_IDS
        Set f = rngLookup.Find(l, LookIn:=xlValues, lookat:=xlWhole)
        If Not f Is Nothing Then
            v = f.Row
        Else
            v = 0
        End If
    Next l
    t2 = Round(Timer - t, 3)
    t1 = 0
    Debug.Print "Find", "Map: 0", "Lookup: " & t2, "Total: " & (t1 + t2)

    'create a lookup map using a dictionary
    t = Timer
    Set d = GetMapDict(rngLookup)
    t1 = Round(Timer - t, 3)
    t = Timer
    For l = 1 To NUM_IDS
        If d.exists(l) Then
            v = d(l)
        Else
            v = 0
        End If
    Next l
    t2 = Round(Timer - t, 5)
    Debug.Print "Dictionary", "Map: " & t1, "Lookup: " & t2, "Total: " & (t1 + t2)
    Set d = Nothing

    'create a lookup map using a collection
    t = Timer
    Set d2 = GetMapCollection(rngLookup)
    t1 = Round(Timer - t, 3)
    t = Timer
    On Error Resume Next
    For l = 1 To NUM_IDS
        d2.Add 0, CStr(l)
        If Err.Number <> 0 Then
            'found!
            Err.Clear
        End If
    Next l
    t2 = Round(Timer - t, 5)
    Debug.Print "Collection", "Map: " & t1, "Lookup: " & t2, "Total: " & (t1 + t2)
    Set d = Nothing


    'use Match()
    t1 = 0
    t = Timer
    For l = 1 To NUM_IDS
        v = Application.Match(l, rngLookup, 0)
        If IsError(v) Then v = 0
    Next l
    t2 = Round(Timer - t, 3)
    Debug.Print "Match", "Map: " & t1, "Lookup: " & t2, "Total: " & (t1 + t2)

End Sub


Function GetMapCollection(rng) As Object
    Dim d As New Collection, v, arr, ub As Long, r As Long, r1 As Long
    Dim c As Range

    arr = rng.Value
    r1 = rng.Cells(1).Row
    ub = UBound(arr, 1)
    For r = 1 To ub
        v = arr(r, 1)
        If Len(v) > 0 Then
            On Error Resume Next
            d.Add r1 + (r - 1), CStr(v)
            On Error GoTo 0
        End If
    Next r
    Set GetMapCollection = d
End Function



Function GetMapDict(rng) As Object
    Dim d, v, arr, ub As Long, r As Long, r1 As Long
    Dim c As Range
    Set d = CreateObject("scripting.dictionary")
    arr = rng.Value
    r1 = rng.Cells(1).Row
    ub = UBound(arr, 1)
    For r = 1 To ub
        v = arr(r, 1)
        If Len(v) > 0 Then
            If d.exists(v) Then
                d(v) = d(v) & "|" & r1 + (r - 1)
            Else
                d.Add v, r1 + (r - 1)
            End If
        End If
    Next r
    Set GetMapDict = d
End Function

vba - Excel VBA - 1 つのワークブックの列を反復処理し、対応するワークブックに情報を貼り付けます

1 に答える 1

Related

Reference