Доступ с использованием VBA для автоматического сопоставления записей между двумя наборами записей.

У меня есть база данных в Access и еще одна таблица в excel.

Я пытаюсь создать макрос согласования в доступе, который, надеюсь, пометит все записи в доступе, которые имеют совпадающую запись в Excel. Excel также будет помечен, поэтому я буду знать, какие записи не были сопоставлены, чтобы просмотреть их вручную.

Что я сделал до сих пор, так это преобразовал таблицу excel в массив, а затем переместил его в набор записей «ldict», чтобы уменьшить взаимодействие с рабочим листом и, надеюсь, ускорит макрос.

Я сделал то же самое с таблицей в Access и переместил ее в набор записей «RS».

На данный момент я использую вложенные циклы. Он будет перемещаться по каждой записи в ldict, а затем перебирать каждую запись в RS, чтобы найти совпадение.

Когда он находит совпадение, у меня есть логическое поле «CMN_REV» в RS, которое будет установлено в TRUE, чтобы указать, что оно было сопоставлено.

В ldict он скопирует соответствующий PK_ID из RS как запись того, что было сопоставлено.

Dim xl As Excel.Application, wb As Excel.Workbook, lfilepath As String, ldict As ADODB.Recordset, lrow As Long, i As Long, _
legacy As Excel.Worksheet, legacy2 As Excel.Worksheet, str As String, arr() As Variant

'setup ldict
Set ldict = New ADODB.Recordset
With ldict.Fields
    .Append ......
End With
ldict.Open

'set legacy file
lfilepath = Dir(Application.CurrentProject.Path & "\test.csv")
Set xl = CreateObject("Excel.application")
With xl
    .DisplayAlerts = False
    .Visible = True
    Set wb = .Workbooks.Open(Application.CurrentProject.Path & "\" & lfilepath)
    Set legacy = wb.Worksheets(1)


    'move excel to array to recordset.
    With legacy

        lrow = .Range("A" & .Rows.count).End(xlUp).Row
        arr = .Range("A1:AM" & lrow)

        For i = 2 To UBound(arr, 1)
                With ldict
                    .AddNew
                    .......
                    .Update
                End With
        Next i
        Erase arr()

        Set legacy2 = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count))
        legacy2.Name = "Results"
        wb.SaveAs FileName:=Application.CurrentProject.Path & "\" & "Output", FileFormat:=xlOpenXMLWorkbook, _
            ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges

    End With
    .DisplayAlerts = True
End With


'setup RS
Dim rs As Recordset, qdf As DAO.QueryDef
Set rs = CurrentDb.OpenRecordset("Unpaid query")
Set qdf = CurrentDb.CreateQueryDef("")

qdf.sql = "Update AR_Consolidated set CMN_REV = '0'"
qdf.Execute dbFailOnError

ldict.MoveFirst
rs.MoveFirst

'compare loop
While Not ldict.EOF

    'end of rs wend sets absolute to -1. check to reset to first position
    If rs.EOF = True Then
        rs.MoveFirst
    End If

    While Not rs.EOF

        'convert rs expiry to dates
        Select Case Left(rs("MON_YR"), 3)
            Case Is = "JAN"
                i = 1
            Case Is = "FEB"
                i = 2
            Case Is = "MAR"
                i = 3
            Case Is = "APR"
                i = 4
            Case Is = "MAY"
                i = 5
            Case Is = "JUN"
                i = 6
            Case Is = "JUL"
                i = 7
            Case Is = "AUG"
                i = 8
            Case Is = "SEP"
                i = 9
            Case Is = "OCT"
                i = 10
            Case Is = "NOV"
                i = 11
            Case Is = "DEC"
                i = 12
        End Select

        'check conditions
        If rs("CMN_REV") = False _
        And (Trim(ldict("area")) = Trim(rs("area")) Or Trim(ldict("area")) = Trim(rs("MIC"))) _
        And Trim(ldict("Firm")) = Trim(rs("Firm")) _
        And ldict("Product") = rs("Product_Code") _
        And ldict("Expiry") = DateSerial(Right(rs("MON_YR"), 2), i, "01") _
        And Round(ldict("Price"), 3) = Round(Val(rs("Price")), 3) _
        And ldict("Date") = rs("Date") _
        And ldict("Quantity") = rs("Quantity") And ldict("Amount") = rs("Amount") _
        And ldict("BuySell") = rs("BUY/SELL") _
        And ldict("Currency") = rs("CurrCode") _
        And ldict("Amount") = rs("Amount") _
        Then

        'perform actions if matched

            'set matched indicator in rs
            rs.Edit
                rs![CMN_REV] = True
            rs.Update

            ldict("PK_ID").Value = rs("PK_ID").Value
            ldict.Update


            GoTo a
        End If
        rs.MoveNext
    Wend
a:
    ldict.MoveNext
Wend

'copy from ldict into excel

If ldict.BOF = False And ldict.EOF = False Then
    ldict.MoveFirst
End If
legacy2.Range("A2").CopyFromRecordset ldict
wb.Save

Хотя код работает отлично, он, к сожалению, слишком медленный. У меня есть в среднем 100 тысяч записей для каждого набора записей, и, похоже, это занимает часы, если не дни.

По мере того, как он переходит к каждой записи в ldict, он снова проходит через начало RS.

Я рассматриваю возможность удаления совпадающих записей в RS, когда он их находит, поэтому ему не нужно снова просматривать ту же запись в следующем цикле, но я полагаю, что это также удалит ее из моей таблицы в Access.

Я читал некоторые предложения о том, что использование объединенных SQL-запросов будет быстрее, но я не уверен, как подойти к этому, чтобы добиться тех же результатов.

У кого-нибудь есть лучшие предложения?

Спасибо.