时间戳

首页 > 解决方案 > 访问，使用 VBA 自动匹配 2 个记录集之间的记录

sql - 访问，使用 VBA 自动匹配 2 个记录集之间的记录

问题描述

我在 Access 中有一个数据库，在 excel 中有另一个表。

我正在尝试在 access 中构建一个协调宏，这将有望标记 Access 中在 excel 中具有匹配条目的所有记录。excel也会被标记掉，所以我会知道哪些记录没有匹配到手动查看。

到目前为止，我所做的是将 excel 表转换为数组，然后将其移动到记录集“ldict”中以减少工作表交互，并有望加快宏的速度。

我对 Access 中的表做了同样的事情，并将其移动到记录集“RS”中。

在这一点上，我一直在使用嵌套循环。它将遍历 ldict 中的每条记录，然后遍历 RS 中的每条记录以查找匹配项。

当它找到匹配项时，我在 RS 中有一个布尔字段“CMN_REV”，它将设置为 TRUE 以指示它已匹配。

在 ldict 中，它将从 RS 复制匹配的 PK_ID，作为匹配内容的记录。

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

虽然代码运行良好，但不幸的是太慢了。每个记录集我平均有 100k 条记录，如果不是几天，它似乎需要几个小时。

当它移动到 ldict 中的每条记录时，它将再次循环通过 RS 的开头。

我已经考虑在 RS 中找到匹配的记录时可能会删除它，因此它不必在下一个循环中再次查看相同的记录，但我相信这也会将它从我的 Access 表中删除。

我已经阅读了一些建议，即使用连接的 SQL 查询会更快，但我不确定如何实现相同的结果。

有人有更好的建议吗？

谢谢你。

标签： sqlvbams-accessrecordsetdatabase-reconciliation

解决方案

使用 SQL 而不是 VBA 执行此操作的一种可能性是从 Excel 工作簿在 Access 中创建链接表。然后，您可以对这两个数据集运行查询。

我不确定是否直接更新您的 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

推荐阅读