Optimering
HejJeg har et optimeringsproblem, det relaterer sig til spm http://www.eksperten.dk/spm/901908
Det er klart at nedenstående kode tager lang tid at afvikle (ca. 2 min for 1000 rekvirenter med 2000 kontakter). Og den tid vil jo vokse eksponentielt med udbygningen :-(
Har i nogen triks til hvordan det kan speedes op, eller gøres mere effektivt.
Opgaven er simpel, find alle dem som releterer til en post, tag deres initaler, og læg til en teksstreng i den pågældende post. Denne info skal opdateres ved nye/slettede relationer, og nemmest er jo at lave det hele igen.
Mvh.
Option Compare Database
Option Explicit
Public Function update_RR_contact_field()
On Error GoTo Errorhandler
Dim db As DAO.Database
Dim rst As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim rst3 As DAO.Recordset
Dim RR_contacts_string As String
Dim sSQL As String
Dim sSQL2 As String
Dim sSQL3 As String
Dim sSQL4 As String
Dim temp As Integer
temp = 0
'DoCmd.Hourglass True
'Vælg alle de rekvirenter som har en relation til RR-person
sSQL = "SELECT tbl_rekvirent.ID, tbl_RR_person.forkortelse, tbl_rekvirent_RR_person.primarykontact, tbl_rekvirent_RR_person.julekort " & _
"FROM tbl_rekvirent INNER JOIN (tbl_RR_person INNER JOIN tbl_rekvirent_RR_person ON tbl_RR_person.ID = tbl_rekvirent_RR_person.RR_personID) ON tbl_rekvirent.ID = tbl_rekvirent_RR_person.rekvirentID ORDER BY tbl_rekvirent.ID;"
Set db = CurrentDb
Set rst = db.OpenRecordset(sSQL, dbOpenSnapshot)
DoCmd.SetWarnings False
If Not rst.BOF Then rst.MoveFirst
Do Until rst.EOF
RR_contacts_string = ""
'Find de primære relationer
sSQL2 = "SELECT tbl_RR_person.forkortelse " & _
"FROM tbl_rekvirent INNER JOIN (tbl_RR_person INNER JOIN tbl_rekvirent_RR_person ON tbl_RR_person.ID = tbl_rekvirent_RR_person.RR_personID) ON tbl_rekvirent.ID = tbl_rekvirent_RR_person.rekvirentID " & _
"WHERE (((tbl_rekvirent.ID)=" & rst.Fields(0) & ") AND ((tbl_rekvirent_RR_person.primarykontact)=True));"
Set rst2 = db.OpenRecordset(sSQL2, dbOpenSnapshot)
If Not rst2.BOF Then rst2.MoveFirst
Do Until rst2.EOF
RR_contacts_string = RR_contacts_string & rst2.Fields(0) & " "
'MsgBox rst2.Fields(0), vbOKOnly, RR_contacts_string & "rst2" ' testudlæsning
rst2.MoveNext
Loop
'Find sekundære relationer
sSQL3 = "SELECT tbl_RR_person.forkortelse " & _
"FROM tbl_rekvirent INNER JOIN (tbl_RR_person INNER JOIN tbl_rekvirent_RR_person ON tbl_RR_person.ID = tbl_rekvirent_RR_person.RR_personID) ON tbl_rekvirent.ID = tbl_rekvirent_RR_person.rekvirentID " & _
"WHERE (((tbl_rekvirent.ID)=" & rst.Fields(0) & ") AND ((tbl_rekvirent_RR_person.primarykontact)=False));"
Set rst3 = db.OpenRecordset(sSQL3, dbOpenSnapshot)
If Not rst3.BOF Then rst3.MoveFirst
Do Until rst3.EOF
RR_contacts_string = RR_contacts_string & rst3.Fields(0) & " "
'MsgBox rst3.Fields(0) & " - " & rst.Fields(0), vbOKOnly, RR_contacts_string & "rst3" ' testudlæsning
rst3.MoveNext
Loop
RR_contacts_string = Left(RR_contacts_string, Len(RR_contacts_string) - 1) 'Fjern sidste charecter
'MsgBox RR_contacts_string, vbOKOnly, rst.Fields(0) ' testudlæsning
'Opdater feltet rekvirenttabellen
sSQL4 = "UPDATE tbl_rekvirent SET tbl_rekvirent.RR_contacts = '" & RR_contacts_string & "' WHERE (((tbl_rekvirent.ID)=" & rst.Fields(0) & "));"
DoCmd.RunSQL sSQL4
'Afbryder til begrænset test
'temp = temp + 1
'If temp = 5 Then
' GoTo Exit_fcn
'End If
rst.MoveNext 'næste rekvirent
Loop
GoTo Exit_fcn
Exit_fcn:
'DoCmd.Hourglass = False
DoCmd.SetWarnings True
Set db = Nothing
Set rst = Nothing
Set rst2 = Nothing
Set rst3 = Nothing
Exit Function
Errorhandler:
MsgBox Err, vbOKOnly, "Fejl"
GoTo Exit_fcn
End Function
