Code:
PrivateSub Command13_Click()
Dimdb As Database
Dimrsdata As Recordset, rstally As Recordset
Dimrskey As Recordset, rstext As Recordset
DimBdate As Date
DimEdate As Date
Dimtst As String
Dimtxt As String, cnt As Integer
Dimans As Integer, j As Integer, k As Integer
Dimxkey As Integer, xmonth As Integer, xquarter As Integer, xyear AsInteger
Dimkeywant As Integer, qtrwant As Integer, yerwant As Integer
Dimsurvey_form As Integer 'indicates which question set to use
Dimqcvt(12) As Integer, flipit As Boolean
Dimrefcode As String
DimS(20) As Long
Dimscores(20, 6) As Long
Dimv1 As Long, v2 As Long
Dimmsg, style, response
Setdb = CurrentDb()
Setrsdata = db.OpenRecordset("Data", dbOpenTable)
rsdata.Index= "IDNmb"
Setrstally = db.OpenRecordset("Tally", dbOpenTable)
Setrskey = db.OpenRecordset("Types", dbOpenTable)
rskey.Index= "Key"
Setrstext = db.OpenRecordset("QText", dbOpenTable)
rstext.Index= "RCode"
qcvt(1)= 1
qcvt(2)= 1
qcvt(3)= 1
qcvt(4)= 2
qcvt(5)= 2
qcvt(6)= 2
qcvt(7)= 3
qcvt(8)= 3
qcvt(9)= 3
qcvt(10) =4
qcvt(11) =4
qcvt(12) =4
'--------------------
rskey.MoveFirst
DoWhile Not rskey.EOF
keywant =rskey!Key
survey_form= rskey!Key
qtrwant =Forms!PreRep!TheQuarter
yerwant =Forms!PreRep!TheYear
Forms!Main!RpTitle= rskey!Descript & " Totals Report"
GoSubDoTally
msg= rskey!Descript & " - Print ?"
style= vbYesNo + vbCritical + vbDefaultButton2
response =MsgBox(msg, style)
Ifresponse = vbYes Then ' User chose Yes.
DoCmd.OpenReport"Report1" ', acViewPreview
DoCmd.OpenReport"Report2" ', acViewPreview
EndIf
rskey.MoveNext
Loop
'--------------------
rsdata.Close
rstally.Close
rskey.Close
rstext.Close
ExitSub
'=================================================
DoTally:
DoCmd.SetWarningsFalse
DoCmd.RunSQL"delete * from Tally;"
Forj = 1 To 20
Fork = 1 To 6
scores(j,k) = 0
Next k
Next j
DoCmd.SetWarningsTrue
rsdata.MoveFirst
DoWhile Not rsdata.EOF
IfLen(rsdata!Batch) = 7 Then
xmonth =Val(Left(rsdata!Batch, 2))
xquarter =qcvt(xmonth)
If qtrwant= 5 Then xquarter = 5 'avz
xyear =Val(Mid(rsdata!Batch, 4, 4))
xkey =rsdata!Type
'avz Ifkeywant = 6 And xkey = 10 Then xkey = 6 'include Radiology in OPServices totals
Else
xquarter =0
EndIf
If(xkey = keywant) And (xquarter = qtrwant) And (xyear = yerwant) Then
Debug.PrintStr(rsdata!IDNmb) & "--" & rsdata!Batch & "--"& Str(rsdata!Type)
S(1) =Nz(rsdata!Q1)
S(2) =Nz(rsdata!Q2)
'---------
If S(2) >9 Then
v1 = S(2)
v2 = (v1 /10)
S(2) = v1 -(v2 * 10)
End If
'---------
S(3) =Nz(rsdata!Q3)
S(4) =Nz(rsdata!Q4)
S(5) =Nz(rsdata!Q5)
S(6) =Nz(rsdata!Q6)
S(7) =Nz(rsdata!Q7)
S(8) =Nz(rsdata!Q8)
S(9) =Nz(rsdata!Q9)
S(10) =Nz(rsdata!Q10)
S(11) =Nz(rsdata!Q11)
S(12) =Nz(rsdata!Q12)
S(13) =Nz(rsdata!Q13)
S(14) =Nz(rsdata!Q14)
S(15) =Nz(rsdata!Q15)
S(16) =Nz(rsdata!Q16)
S(17) =Nz(rsdata!Q17)
S(18) =Nz(rsdata!Q18)
S(19) =Nz(rsdata!Q19)
S(20) =Nz(rsdata!Q20)
Debug.PrintStr(rsdata!IDNmb) & "--" & rsdata!Batch & "--"& Str(rsdata!Type)
For k = 1To 20
If Nz(S(k),0) > 0 Then
scores(k,S(k)) = scores(k, S(k)) + 1
scores(k,6) = scores(k, 6) + 1
End If
Next k
EndIf
rsdata.MoveNext
Loop
'--------------
'Debug.Print"Check Point Alpha"
Fork = 1 To 20
rstally.AddNew
rstally!SurveyID= 1
rstally!QNmb= k
refcode =Format(survey_form, "00") & Format(k, "00")
'Debug.Printrefcode
rstally!RCode= refcode
rstext.Seek"=", refcode
Ifrstext.NoMatch Then
flipit =False
Else
flipit =rstext!Flip
EndIf
Ifflipit = True Then
rstally!VeryGood= scores(k, 1)
rstally!Good= scores(k, 2)
rstally!Fair= scores(k, 3)
rstally!Poor= scores(k, 4)
rstally!Excellent= scores(k, 5)
rstally!Total= scores(k, 6)
Ifscores(k, 6) > 0 Then
rstally!VeryGoodPct= scores(k, 1) / scores(k, 6)
rstally!GoodPct= scores(k, 2) / scores(k, 6)
rstally!FairPct= scores(k, 3) / scores(k, 6)
rstally!PoorPct= scores(k, 4) / scores(k, 6)
rstally!ExcellentPct= scores(k, 5) / scores(k, 6)
End If
Else
rstally!Poor= scores(k, 1)
rstally!Fair= scores(k, 2)
rstally!Good= scores(k, 3)
rstally!VeryGood= scores(k, 4)
rstally!Excellent= scores(k, 5)
rstally!Total= scores(k, 6)
Ifscores(k, 6) > 0 Then
rstally!PoorPct= scores(k, 1) / scores(k, 6)
rstally!FairPct= scores(k, 2) / scores(k, 6)
rstally!GoodPct= scores(k, 3) / scores(k, 6)
rstally!VeryGoodPct= scores(k, 4) / scores(k, 6)
rstally!ExcellentPct= scores(k, 5) / scores(k, 6)
End If
EndIf
rstally.Update
Nextk
'--------------
Return
EndSub