I have a database in Access, and another table in excel.
I'm trying to build a reconciliation macro within access, that will hopefully mark all the records in Access that have a matching entry in excel. The excel will also be marked off, so I will know which records were not matched to look at manually.
What I've done so far is to convert the excel table into an array, then move that into a recordset "ldict" to reduce the worksheet interaction and hopefully will speed up the macro.
I did the same with the table in Access, and moved it into a recordset "RS".
At this point, I've been using nested loops. It'll move through each record in ldict, then loop through each record in RS to find a match.
When it finds a match, I have a boolean field "CMN_REV" in RS that will be set to TRUE to indicate it was matched.
In ldict, it will copy the matched PK_ID from RS, as a record of what was matched.
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
While the code works perfectly, it is unfortunately too slow. I have avg 100k records for each recordset, and it seems to take hours if not days.
As it moves on to each record in ldict, it will loop through the beginning of RS again.
I've consider possibly removing matched records in RS when it finds one, so it does not have to look at the same record again on the next loop, but i believe this will also remove it from my Table in Access.
I've read some suggestions that using joined SQL queries would be faster, but i'm not sure how to approach this to achieve the same results.
Anyone have any better suggestions?
Thank you.
One possibility for doing this with SQL instead of VBA would be creating a linked table in Access from your Excel workbook. Then you can run a query against the two datasets.
I'm not sure about directly updating your Excel file, but you should at least be able to use a select query to see which rows in Excel aren't matched. Untested, but something like this is the general idea:
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
)
EDIT: Per the question below, if you wanted to find the matches, and you wanted to be able to show fields from both tables, you could use a JOIN instead of EXISTS. You could probably reduce the number of fields in the join, but because I'm not familiar with your data I'm going to assume here that all fields are necessary to make a proper match.
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