Access にデータベースがあり、Excel に別のテーブルがあります。
アクセス内で調整マクロを作成しようとしています。これにより、Excel で一致するエントリを持つアクセス内のすべてのレコードがマークされることが期待されます。Excel にもマークが付けられるので、どのレコードが一致しなかったかを手動で確認できます。
これまでに行ったことは、Excel テーブルを配列に変換し、それをレコードセット "ldict" に移動して、ワークシートの相互作用を減らし、うまくいけばマクロを高速化することです。
Access のテーブルでも同じことを行い、それをレコードセット "RS" に移動しました。
この時点で、ネストされたループを使用しています。ldict の各レコードを移動し、次に RS の各レコードをループして一致を見つけます。
一致が見つかった場合、RS にブール フィールド「CMN_REV」があり、一致したことを示すために 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
コードは完全に機能しますが、残念ながら遅すぎます。レコードセットごとに平均 10 万件のレコードがあり、数日ではないにしても数時間かかるようです。
ldict の各レコードに移動すると、RS の先頭を再びループします。
RSで一致するレコードが見つかったときに削除する可能性があるため、次のループで同じレコードを再度調べる必要はありませんが、これによりAccessのテーブルからも削除されると思います。
結合された SQL クエリを使用する方が高速であるという提案をいくつか読みましたが、これにアプローチして同じ結果を得る方法がわかりません。
誰にもより良い提案がありますか？
ありがとうございました。