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

Question

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

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

До сих пор я конвертировал таблицу Excel в массив, а затем переместил ее в набор записей "ldict", чтобы уменьшить взаимодействие с рабочим листом и, надеюсь, ускорит макрос.

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

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

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

В конце концов, он скопирует сопоставленный 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

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

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

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

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

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

Спасибо.

Answer 1

Одной из возможностей сделать это с помощью SQL вместо VBA было бы создание связанной таблицы в Access из вашей книги Excel. Затем вы можете выполнить запрос к двум наборам данных.

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

select * 
from [YourExcelTable] e
where not exists (
  select 1
  from [YourAccessTable] a
  where (Trim(e.area) = Trim(a.area) Or Trim(e.area) = Trim(a.MIC))
        And Trim(e.Firm) = Trim(a.Firm)
        And e.Product = a.Product_Code
        And e.Expiry = DateSerial(Right(a.MON_YR, 2), i, "01")
        And Round(e.Price, 3) = Round(Val(a.Price), 3)
        And e.Date = a.Date
        And e.Quantity = a.Quantity 
        And e.Amount = a.Amount
        And e.BuySell = a.[BUY/SELL]
        And e.Currency = a.CurrCode
        And e.Amount = a.Amount
)

РЕДАКТИРОВАТЬ: В соответствии с вопросом ниже, если вы хотите найти совпадения, и вы хотите иметь возможность отображать поля из обеих таблиц, вы можете использовать JOIN вместо EXISTS. Возможно, вы могли бы уменьшить количество полей в объединении, но поскольку я не знаком с вашими данными, я собираюсь предположить, что все поля необходимы для правильного соответствия.

select e.*, a.ID
from [YourExcelTable] e
inner join [YourAccessTable] a
    On (Trim(e.area) = Trim(a.area) Or Trim(e.area) = Trim(a.MIC))
        And Trim(e.Firm) = Trim(a.Firm)
        And e.Product = a.Product_Code
        And e.Expiry = DateSerial(Right(a.MON_YR, 2), i, "01")
        And Round(e.Price, 3) = Round(Val(a.Price), 3)
        And e.Date = a.Date
        And e.Quantity = a.Quantity 
        And e.Amount = a.Amount
        And e.BuySell = a.[BUY/SELL]
        And e.Currency = a.CurrCode
        And e.Amount = a.Amount