Relationship goes Certification can have multiple variations (any single
variation satifies the certification), which require multiple course groups
which require any one of the products assigned to the group.
MS Access.. VBA.. got very many sub relationships and it takes about 30
seconds to see who is certified. But now my problem is I want to go back
through the process and see who is only 1 course group away from being
certified, and if they are only 1 course away which products that means they
need to achieve that course group, thereby achieving the certification.
Since I need to know if only 1 fails it turns into a looping question rather
then a simple SQL statement generation (right?) and this means it takes about
30-100 seconds per a member. I have 7000 members.. ekkkk
Geez.. even if it only takes 2 seconds per a member that means it will be a
routine that takes 4 hours to run.
Private Sub CertificationRe viewCMD_Click()
'On Error GoTo Err_Certificati onReviewCMD_Cli ck
'Loop through each member (customerid)
'Loop through each certification
'test if certification is already attained by this particular member
'Loop through each variation for each certification
'at end of variation loop if we are only missing 1 coursegroup then
'put the required product id's into the table
'Loop through each course group for each variation
'Loop through each product id for each course group
'if missingcoursegr oup 1 then
'skip to next variation
'Does this member have status(15) for the required product id?
'if yes then goto next course group
'if course group has no matching product ids then
'next course group
'missingcourseg roup + 1
Dim MemberID, CertID, VariationID, CourseGroupID, CurrentProductI D
Dim strSQL
Dim rsVariations
Dim rsCourseGroups
Dim rsCompletedProd ucts 'accredited product ids
Dim MissingCourseGr oup 'number of course groups missing for variation
Dim rsMissingProduc ts 'list products necessary to meet the course group
needs
Dim rsMissingCertif ication 'add products to the proper table
Dim rsMembers 'customer id list
Dim rsCertification s 'all active certifications to test for each member
Dim MemberCounter
Dim rsCertification Acheived 'certification already certified
Dim strTime, MemberStart 'start time for timer
Dim MaxMember
DoCmd.Hourglass True
MemberCounter = 0
strTime = Now
MemberStart = Now
'clear tbl_Certificati onMissing for repopulation
'CurrentDb.Exec ute "Delete * from tbl_Certificati onMissing"
DoCmd.SetWarnin gs False
DoCmd.RunSQL "Delete * from tbl_Certificati onMissing"
DoCmd.SetWarnin gs True
strSQL = "Select * from tbl_Customers" 'this is my 7000 members
Set rsMembers = CurrentDb.OpenR ecordset(strSQL , dbOpenSnapshot, dbReadOnly)
If rsMembers.EOF Then
MsgBox "There are no members in the system."
Else
rsMembers.MoveL ast
MaxMember = rsMembers.Recor dCount
'start progress meter
'http://support.microso ft.com/default.aspx?sc id=kb;EN US;Q103404
'syscmd(1,"text ",100) will set the meter to maximum of 100
'syscmd(2,25) will set current progress to 25/100 or 25% in this example
'syscmd(3) closes meter
'RetVal = SysCmd(1, "Calculatin g Certifications. ..", MaxMember)
rsMembers.MoveF irst
Do Until rsMembers.EOF
MemberID = rsMembers("Cust omerID")
'debug.print "MemberID >" & MemberID & "<"
MemberCounter = MemberCounter + 1
'RetVal = SysCmd(2, MemberCounter)
SysCmd acSysCmdSetStat us, "Calculatin g Member " & MemberCounter & "/" &
MaxMember
strSQL = "SELECT tbl_Schedule_Co urses.ProductID " _
& " FROM tbl_Schedule_Co urses INNER JOIN (tbl_TraineeCou rses INNER JOIN
tbl_Schedule_Da tes " _
& " ON tbl_TraineeCour ses.ScheduleCou rseID = tbl_Schedule_Da tes.
ScheduleCourseI D) ON " _
& " tbl_Schedule_Co urses.ScheduleI D = tbl_Schedule_Da tes.ScheduleID " _
& " WHERE (((tbl_TraineeC ourses.Customer ID)=" & MemberID & ") AND (
(tbl_TraineeCou rses.Status)='1 5'));"
Set rsCompletedProd ucts = CurrentDb.OpenR ecordset(strSQL , dbOpenSnapshot,
dbReadOnly)
If rsCompletedProd ucts.EOF Then
'this member has not completed/accredited any courses skip
Else
strSQL = "Select * from tbl_Certificati ons where active=true"
Set rsCertification s = CurrentDb.OpenR ecordset(strSQL , dbOpenSnapshot,
dbReadOnly)
If rsCertification s.EOF Then
MsgBox "There are no certifications in the system."
Else
Do Until rsCertification s.EOF
CertID = rsCertification s("Certificatio nID")
'debug.print "CertID >" & CertID & "<"
'test if member already has certificate
strSQL = "SELECT tbl_Certified.C ustomerID, tbl_Certified.C ertificateID "
_
& " FROM tbl_Certified WHERE (((tbl_Certifie d.CustomerID)=" & MemberID &
") " _
& " AND ((tbl_Certified .CertificateID) =" & CertID & "));"
Set rsCertification Acheived = CurrentDb.OpenR ecordset(strSQL ,
dbOpenSnapshot, dbReadOnly)
If rsCertification Acheived.EOF Then
'good to test
strSQL = "SELECT TOP 100 PERCENT tbl_Certificati onVariation.Var iationID FROM
" _
& " tbl_Certificati onVariation INNER JOIN tbl_Certificati ons ON " _
& " tbl_Certificati onVariation.Cer tificationID = tbl_Certificati ons.
CertificationID WHERE " _
& "(tbl_Certifica tions.Certifica tionID = " & CertID & ")"
Set rsVariations = CurrentDb.OpenR ecordset(strSQL , dbOpenSnapshot, dbReadOnly)
If rsVariations.EO F Then
MsgBox "There are no variations for certificate id #" & CertID & ""
Else
Do Until rsVariations.EO F
MissingCourseGr oup = 0
VariationID = rsVariations("V ariationID")
'debug.print "Variation ID >" & VariationID & "<"
strSQL = "SELECT TOP 100 PERCENT tbl_Certificati onLink.CourseID FROM
" _
& " tbl_Certificati onVariation INNER JOIN tbl_Certificati onLink ON "
_
& " tbl_Certificati onVariation.Var iationID = tbl_Certificati onLink.
VariationID " _
& " WHERE (tbl_Certificat ionVariation.Va riationID = " & VariationID &
")"
Set rsCourseGroups = CurrentDb.OpenR ecordset(strSQL , dbOpenSnapshot,
dbReadOnly)
If rsCourseGroups. EOF Then
MsgBox "There are no course groups for variation id #" &
VariationID & " within certification id #" & CertID
Else
Do Until rsCourseGroups. EOF
If MissingCourseGr oup 1 Then
'too many CourseGroups missing, just skip
Exit Do
Else
CourseGroupID = rsCourseGroups( "CourseID")
'debug.print "CourseGrou pID >" & CourseGroupID & "<"
NeededCourseGro up = CourseGroupID
strSQL = "SELECT ProductID FROM tbl_CourseLinks WHERE " _
& "(CourseID = " & CourseGroupID & ")"
Set rsProducts = CurrentDb.OpenR ecordset(strSQL ,
dbOpenSnapshot, dbReadOnly)
If rsProducts.EOF Then
MsgBox "There are no products for course group id #"
& CourseGroupID & " for variation id #" & VariationID & " within
certification id #" & CertID
Else
Do Until rsProducts.EOF
CurrentProductI D = rsProducts("Pro ductID")
'debug.print "CurrentProduct ID >" &
CurrentProductI D & "<"
found = False
rsCompletedProd ucts.MoveFirst
'CompletedProdu cts is usually only about a dozen or so at any given time
'check for match between the needed product and
the rsCompletedProd ucts
Do Until rsCompletedProd ucts.EOF
'debug.print "Comparing Products, " &
rsCompletedProd ucts("ProductID ") & " to " & CurrentProductI D & "."
If rsCompletedProd ucts("ProductID ") =
CurrentProductI D Then
'debug.print "FOUND!"
found = True
NeededCourseGro up = Null
Exit Do
End If
rsCompletedProd ucts.MoveNext
Loop
If found Then
Exit Do
End If 'course group just needs one product
match
rsProducts.Move Next
Loop
End If 'rsProducts
If Not found Then
MissingCourseGr oup = MissingCourseGr oup + 1
End If 'was the product needed found?
rsCourseGroups. MoveNext
End If
Loop
End If 'rsCourseGroups
If MissingCourseGr oup = 1 Then
'find the product id to full fill this certification
'MsgBox "Member: " & MemberID & Chr(10) _
& "Certificat ion: " & CertID & Chr(10) _
& "Variation: " & VariationID & Chr(10) _
& "Course Group: " & CourseGroupID & Chr(10)
'simply write the products necessary to achieve the certification, via which
variation, for which course group into a table to reference in the future --
this is the whole point of this sub
strSQL = "SELECT tbl_CourseLinks .CourseID, tbl_CourseLinks .
ProductID " _
& " FROM tbl_CourseLinks WHERE (((tbl_CourseLi nks.CourseID)=" &
CourseGroupID & "));"
Set rsMissingProduc ts = CurrentDb.OpenR ecordset(strSQL ,
dbOpenSnapshot, dbReadOnly)
If rsMissingProduc ts.EOF Then
MsgBox "The course group #" & CoursGroupID & " you require
has no products attached."
Else
Do Until rsMissingProduc ts.EOF
Set rsMissingCertif ication = CurrentDb.OpenR ecordset
("tbl_Certifica tionMissing", dbOpenDynaset, dbSeeChanges)
rsMissingCertif ication.AddNew
rsMissingCertif ication("CertID ") = CertID
rsMissingCertif ication("Variat ionID") = VariationID
rsMissingCertif ication("Produc tID") =
rsMissingProduc ts("ProductID" )
rsMissingCertif ication("Custom erID") = MemberID
rsMissingCertif ication("Course GroupID") =
CourseGroupID
rsMissingCertif ication.Update
rsMissingProduc ts.MoveNext
Loop
rsMissingCertif ication.Close
Set rsMissingCertif ication = Nothing
End If 'rsMissingProdu cts
rsMissingProduc ts.Close
Set rsMissingProduc ts = Nothing
End If
rsVariations.Mo veNext
Loop
End If 'variations
rsVariations.Cl ose
Set rsVariations = Nothing
rsCourseGroups. Close
Set rsCourseGroups = Nothing
End If 'rsCertificatio nAcheived
rsCertification Acheived.Close
Set rsCertification Acheived = Nothing
rsCertification s.MoveNext
Loop
End If 'rsCertificatio ns
rsCertification s.Close
Set rsCertification s = Nothing
End If 'rsCompletedPro ducts
rsCompletedProd ucts.Close
Set rsCompletedProd ucts = Nothing
Debug.Print "Total Time for Member ID#" & MemberID & ": " & DateDiff("s",
MemberStart, Now) & " seconds, thank you for your patience."
'this is typically about 30-100 seconds per a member
MemberStart = Now
rsMembers.MoveN ext
Loop
End If 'rsMembers
rsMembers.Close
Set rsMembers = Nothing
Exit_Certificat ionReviewCMD_Cl ick:
MsgBox "Total Time: " & DateDiff("n", strTime, Now) & " minutes, thank
you for your patience."
'RetVal = SysCmd(3)
SysCmd acSysCmdClearSt atus ' clear my text from the status bar
DoCmd.Hourglass False
Exit Sub
Err_Certificati onReviewCMD_Cli ck:
MsgBox Err.Description
Resume Exit_Certificat ionReviewCMD_Cl ick
End Sub
--
Message posted via AccessMonster.c om
http://www.accessmonster.com/Uwe/For...ccess/200707/1
