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 CertificationReviewCMD_Click()
'On Error GoTo Err_CertificationReviewCMD_Click
'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 missingcoursegroup 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
'missingcoursegroup + 1
Dim MemberID, CertID, VariationID, CourseGroupID, CurrentProductID
Dim strSQL
Dim rsVariations
Dim rsCourseGroups
Dim rsCompletedProducts 'accredited product ids
Dim MissingCourseGroup 'number of course groups missing for variation
Dim rsMissingProducts 'list products necessary to meet the course group
needs
Dim rsMissingCertification 'add products to the proper table
Dim rsMembers 'customer id list
Dim rsCertifications 'all active certifications to test for each member
Dim MemberCounter
Dim rsCertificationAcheived 'certification already certified
Dim strTime, MemberStart 'start time for timer
Dim MaxMember
DoCmd.Hourglass True
MemberCounter = 0
strTime = Now
MemberStart = Now
'clear tbl_CertificationMissing for repopulation
'CurrentDb.Execute "Delete * from tbl_CertificationMissing"
DoCmd.SetWarnings False
DoCmd.RunSQL "Delete * from tbl_CertificationMissing"
DoCmd.SetWarnings True
strSQL = "Select * from tbl_Customers" 'this is my 7000 members
Set rsMembers = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot, dbReadOnly)
If rsMembers.EOF Then
MsgBox "There are no members in the system."
Else
rsMembers.MoveLast
MaxMember = rsMembers.RecordCount
'start progress meter
'http://support.microsoft.com/default.aspx?scid=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, "Calculating Certifications...", MaxMember)
rsMembers.MoveFirst
Do Until rsMembers.EOF
MemberID = rsMembers("CustomerID")
'debug.print "MemberID >" & MemberID & "<"
MemberCounter = MemberCounter + 1
'RetVal = SysCmd(2, MemberCounter)
SysCmd acSysCmdSetStatus, "Calculating Member " & MemberCounter & "/" &
MaxMember
strSQL = "SELECT tbl_Schedule_Courses.ProductID " _
& " FROM tbl_Schedule_Courses INNER JOIN (tbl_TraineeCourses INNER JOIN
tbl_Schedule_Dates " _
& " ON tbl_TraineeCourses.ScheduleCourseID = tbl_Schedule_Dates.
ScheduleCourseID) ON " _
& " tbl_Schedule_Courses.ScheduleID = tbl_Schedule_Dates.ScheduleID " _
& " WHERE (((tbl_TraineeCourses.CustomerID)=" & MemberID & ") AND (
(tbl_TraineeCourses.Status)='15'));"
Set rsCompletedProducts = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot,
dbReadOnly)
If rsCompletedProducts.EOF Then
'this member has not completed/accredited any courses skip
Else
strSQL = "Select * from tbl_Certifications where active=true"
Set rsCertifications = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot,
dbReadOnly)
If rsCertifications.EOF Then
MsgBox "There are no certifications in the system."
Else
Do Until rsCertifications.EOF
CertID = rsCertifications("CertificationID")
'debug.print "CertID >" & CertID & "<"
'test if member already has certificate
strSQL = "SELECT tbl_Certified.CustomerID, tbl_Certified.CertificateID "
_
& " FROM tbl_Certified WHERE (((tbl_Certified.CustomerID)=" & MemberID &
") " _
& " AND ((tbl_Certified.CertificateID)=" & CertID & "));"
Set rsCertificationAcheived = CurrentDb.OpenRecordset(strSQL,
dbOpenSnapshot, dbReadOnly)
If rsCertificationAcheived.EOF Then
'good to test
strSQL = "SELECT TOP 100 PERCENT tbl_CertificationVariation.VariationID FROM
" _
& " tbl_CertificationVariation INNER JOIN tbl_Certifications ON " _
& " tbl_CertificationVariation.CertificationID = tbl_Certifications.
CertificationID WHERE " _
& "(tbl_Certifications.CertificationID = " & CertID & ")"
Set rsVariations = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot, dbReadOnly)
If rsVariations.EOF Then
MsgBox "There are no variations for certificate id #" & CertID & ""
Else
Do Until rsVariations.EOF
MissingCourseGroup = 0
VariationID = rsVariations("VariationID")
'debug.print "Variation ID >" & VariationID & "<"
strSQL = "SELECT TOP 100 PERCENT tbl_CertificationLink.CourseID FROM
" _
& " tbl_CertificationVariation INNER JOIN tbl_CertificationLink ON "
_
& " tbl_CertificationVariation.VariationID = tbl_CertificationLink.
VariationID " _
& " WHERE (tbl_CertificationVariation.VariationID = " & VariationID &
")"
Set rsCourseGroups = CurrentDb.OpenRecordset(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 MissingCourseGroup 1 Then
'too many CourseGroups missing, just skip
Exit Do
Else
CourseGroupID = rsCourseGroups("CourseID")
'debug.print "CourseGroupID >" & CourseGroupID & "<"
NeededCourseGroup = CourseGroupID
strSQL = "SELECT ProductID FROM tbl_CourseLinks WHERE " _
& "(CourseID = " & CourseGroupID & ")"
Set rsProducts = CurrentDb.OpenRecordset(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
CurrentProductID = rsProducts("ProductID")
'debug.print "CurrentProductID >" &
CurrentProductID & "<"
found = False
rsCompletedProducts.MoveFirst
'CompletedProducts is usually only about a dozen or so at any given time
'check for match between the needed product and
the rsCompletedProducts
Do Until rsCompletedProducts.EOF
'debug.print "Comparing Products, " &
rsCompletedProducts("ProductID") & " to " & CurrentProductID & "."
If rsCompletedProducts("ProductID") =
CurrentProductID Then
'debug.print "FOUND!"
found = True
NeededCourseGroup = Null
Exit Do
End If
rsCompletedProducts.MoveNext
Loop
If found Then
Exit Do
End If 'course group just needs one product
match
rsProducts.MoveNext
Loop
End If 'rsProducts
If Not found Then
MissingCourseGroup = MissingCourseGroup + 1
End If 'was the product needed found?
rsCourseGroups.MoveNext
End If
Loop
End If 'rsCourseGroups
If MissingCourseGroup = 1 Then
'find the product id to full fill this certification
'MsgBox "Member: " & MemberID & Chr(10) _
& "Certification: " & 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_CourseLinks.CourseID)=" &
CourseGroupID & "));"
Set rsMissingProducts = CurrentDb.OpenRecordset(strSQL,
dbOpenSnapshot, dbReadOnly)
If rsMissingProducts.EOF Then
MsgBox "The course group #" & CoursGroupID & " you require
has no products attached."
Else
Do Until rsMissingProducts.EOF
Set rsMissingCertification = CurrentDb.OpenRecordset
("tbl_CertificationMissing", dbOpenDynaset, dbSeeChanges)
rsMissingCertification.AddNew
rsMissingCertification("CertID") = CertID
rsMissingCertification("VariationID") = VariationID
rsMissingCertification("ProductID") =
rsMissingProducts("ProductID")
rsMissingCertification("CustomerID") = MemberID
rsMissingCertification("CourseGroupID") =
CourseGroupID
rsMissingCertification.Update
rsMissingProducts.MoveNext
Loop
rsMissingCertification.Close
Set rsMissingCertification = Nothing
End If 'rsMissingProducts
rsMissingProducts.Close
Set rsMissingProducts = Nothing
End If
rsVariations.MoveNext
Loop
End If 'variations
rsVariations.Close
Set rsVariations = Nothing
rsCourseGroups.Close
Set rsCourseGroups = Nothing
End If 'rsCertificationAcheived
rsCertificationAcheived.Close
Set rsCertificationAcheived = Nothing
rsCertifications.MoveNext
Loop
End If 'rsCertifications
rsCertifications.Close
Set rsCertifications = Nothing
End If 'rsCompletedProducts
rsCompletedProducts.Close
Set rsCompletedProducts = 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.MoveNext
Loop
End If 'rsMembers
rsMembers.Close
Set rsMembers = Nothing
Exit_CertificationReviewCMD_Click:
MsgBox "Total Time: " & DateDiff("n", strTime, Now) & " minutes, thank
you for your patience."
'RetVal = SysCmd(3)
SysCmd acSysCmdClearStatus ' clear my text from the status bar
DoCmd.Hourglass False
Exit Sub
Err_CertificationReviewCMD_Click:
MsgBox Err.Description
Resume Exit_CertificationReviewCMD_Click
End Sub
--
Message posted via AccessMonster.com
http://www.accessmonster.com/Uwe/For...ccess/200707/1
