访问，使用 VBA 自动匹配 2 个记录集之间的记录
Access, using VBA to auto match records between 2 recordsets
我在 Access 中有一个数据库，在 excel 中有另一个 table。
我正在尝试在 Access 中构建协调宏，这有望标记 Access 中在 excel 中具有匹配条目的所有记录。 excel 也会被标记掉，所以我会知道哪些记录没有匹配到手动查看。
到目前为止，我所做的是将 excel table 转换为数组，然后将其移动到记录集中 "ldict" 以减少工作表交互并希望加快速度上宏
我在 Access 中对 table 做了同样的操作，并将其移动到记录集 "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 中找到匹配的记录时可能会删除它，这样它就不必在下一个循环中再次查看相同的记录，但我相信这也会从我的 Table 在访问中。
我读过一些建议，认为使用连接的 SQL 查询会更快，但我不确定如何处理它才能获得相同的结果。
大家有更好的建议吗？
谢谢。
使用 SQL 而不是 VBA 执行此操作的一种可能性是从您的 Excel 工作簿创建一个 linked table in Access。然后您可以 运行 针对这两个数据集进行查询。
我不确定是否可以直接更新您的 Excel 文件，但您至少应该能够使用 select 查询来查看 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
我在 Access 中有一个数据库，在 excel 中有另一个 table。
我正在尝试在 Access 中构建协调宏，这有望标记 Access 中在 excel 中具有匹配条目的所有记录。 excel 也会被标记掉，所以我会知道哪些记录没有匹配到手动查看。
到目前为止，我所做的是将 excel table 转换为数组，然后将其移动到记录集中 "ldict" 以减少工作表交互并希望加快速度上宏
我在 Access 中对 table 做了同样的操作，并将其移动到记录集 "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 中找到匹配的记录时可能会删除它，这样它就不必在下一个循环中再次查看相同的记录，但我相信这也会从我的 Table 在访问中。
我读过一些建议，认为使用连接的 SQL 查询会更快，但我不确定如何处理它才能获得相同的结果。
大家有更好的建议吗？
谢谢。
使用 SQL 而不是 VBA 执行此操作的一种可能性是从您的 Excel 工作簿创建一个 linked table in Access。然后您可以 运行 针对这两个数据集进行查询。
我不确定是否可以直接更新您的 Excel 文件，但您至少应该能够使用 select 查询来查看 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