Sub CalcAllScore(tabb, usetype, ipfile, crittab, evaltab, pri1, pri2, optNo) ' this is the code that calcultes all the actual scores for the main and optional parts of a bid ' P Laidlaw Dec 2 2008 ' input parameters ' ---------------- ' tabb - this is the table where the results are placed usually a RESULTS type of table ' usefile - meaning use "one" for a single scoresheet and "all" for the base and "opt" for a option ' ipfile - the name of the tab holding the raw data .. also used in scoring ' crittab - the tab with criteria data ' evaltab - the tab containing the evaluators and proponents ' pri1 - the 1st primary catagory as selected by the team ' pri2 - the 2nd primary catagory as selected by the team ' optNo - the option catagory as selected by the team ' things to do '----------------- ' check the algorithm in the "one" version ' change teh structure to stop using line numbers and swithh to do-while type ' include automatic building of the whole results table ' there is a flaw in the logic in teh way we get scores .. we overwrite cells so that when we get an update, the data in the cell is overwritten ' the mobility table has too many primary categories .. there should be 10 inc. the Price ' start here ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' get the Evaluators and Proponents Dim eval_full(11) As String Dim eval_init(11) As String Dim bidd_full(11) As String Dim bidd_init(11) As String For i = 1 To 10 eval_full(i) = Worksheets(evaltab).Cells((3 + i), 2) eval_init(i) = Worksheets(evaltab).Cells((3 + i), 3) bidd_full(i) = Worksheets(evaltab).Cells((3 + i), 6) bidd_init(i) = Worksheets(evaltab).Cells((3 + i), 7) Next i ' determine teh correct number of evals and bids to assess nE = 0 nB = 0 For i = 1 To 10 ee = Left$(eval_full(i), 9) bb = Left$(bidd_full(i), 9) If (ee <> "Evaluator" And ee <> " ") Then nE = nE + 1 If (bb <> "proponent" And bb <> " ") Then nB = nB + 1 Next i ' determine the number of primary categories nP = 0 For i = 1 To 10 If (Worksheets(crittab).Cells(42 + i, 12) <> 0) Then nP = nP + 1 Next i ' determine the number of optional categories nO = 0 For i = 1 To 10 If (Worksheets(evaltab).Cells(3 + i, 10) <> "") Then nO = nO + 1 Next i ' set the number of lines to read If (ipfile = "raw") Then nL = 263 If (ipfile = "rawmob") Then nL = 283 ' set the maximum number of secondaty categories nS = 10 ' set the row numbers for the optional bids optnrow = Array(0, 302, 489, 676, 863, 1050, 1237, 1424, 1611, 1798, 1985) If (usetype = "one") Then nE = 1 'usetab = 1 when it is used in an evaluators individual sheet row1 = 31 'this is the row upper left corner of the weights array in the Criteria tab com1 = 12 'this is the column upper left corner of the weights array (ss column L)in the Criteria tab rowstart = 6 'this is the 1st row cell for primary 2 and secondary 1 colstart = 10 'this is the 1st column cell for primary 2 and secondary 1 incr = 16 'this is the row spacing betweeen primary categories incr_ss = 11 'the line spacing between the 1st score and the subscore scorecol1 = 19 'the column of the 1st score scoreincr = 6 'the column spacing between bids allrow1 = 3 ' the 1st row to paste a calculated score result on allcol1 = 4 ' the 1st column to paste a calculated score on allincr = 16 ' the vertical spacing between rows allscr1 = 23 ' the column the allscore starts on ' remap the options to simple numbers, used only in the singlle evaluators version If (mytab = "opt1") Then optionxx = 3 If (mytab = "opt2") Then optionxx = 4 If (mytab = "opt3") Then optionxx = 5 If (mytab = "opt4") Then optionxx = 6 If (mytab = "opt5") Then optionxx = 7 If (mytab = "opt6") Then optionxx = 8 If (mytab = "opt7") Then optionxx = 9 If (mytab = "opt8") Then optionxx = 10 If (mytab = "opt9") Then optionxx = 11 If (mytab = "opt10") Then optionxx = 12 ' dimension arrays Dim maxsco(4) As Single Dim maxsum(6, 5, 11, 6) As Single Dim scosum(6, 5, 11, 6) As Single Dim rifsum(6, 5, 11, 6) As Single Dim numsco(6, 5, 11, 6) As Single Dim rifsco(6, 5, 11, 6) As Single Dim score(6, 5, 11, 6) As Single Dim sumall(5, 11, 6) As Single Dim avgall(4, 11, 6) As Single Dim numall(5, 11, 6) As Single Dim subsco(6, 5, 6) As Single Dim maxsub(6, 5, 6) As Single Dim adjsco(6, 5, 6) As Single Dim totals(6, 6) As Single Dim num_val_pri(6, 6) As Single Dim scored(6, 5, 11, 6) As String Dim num_valid_scores(6, 5, 6) As Single 'this is the number of secondary categories that have at least 1 item scored Dim ps(11, 11) As Single ' ps is the array holding the secondary weights Dim pp As Variant Dim px(11) As Single Dim nScats(11) As Single 'initialize the easy way ( there must be an easier way) For e = 0 To nE For p = 0 To nP For s = 0 To nS For b = 0 To nB scosum(e, p, s, b) = 0 numsco(e, p, s, b) = 0 rifsum(e, p, s, b) = 0 scored(e, p, s, b) = "n" Next b Next s Next p Next e For e = 0 To nB For b = 0 To nB totals(e, b) = 0 num_val_pri(e, b) = 0 For p = 0 To nP maxsub(e, p, b) = 0 subsco(e, p, b) = 0 num_valid_scores(e, p, b) = 0 Next p Next b Next e For p = 0 To nP For s = 0 To nS ps(p, s) = 0 For b = 1 To nB sumall(p, s, b) = 0 numall(p, s, b) = 0 Next b Next s Next p '================================================================================================================================ ' build the headings on the ???Results table 'write out teh number of evaluators for ss calculatio purposes Worksheets(tabb).Cells(1, 15) = nE 'write the titles If tabb = "AllResultsLD" Then Worksheets(tabb).Cells(1, 1) = "Overall Results - Long Distance Telephony" If tabb = "AllResultsMob" Then Worksheets(tabb).Cells(1, 1) = "Overall Results - Mobility Telephony" 'write out the primary category inc = 12 For i = 2 To 10 ' changed from nP so as to overwrite old names Pweight = 100 * Worksheets(crittab).Cells(42 + i, 13) PriCatName = Worksheets(crittab).Cells((18 + (i - 2) * inc), 2) & " - Weight = " & Pweight & "%" Worksheets(tabb).Cells(3 + (16 * (i - 2)), 1) = PriCatName Next i 'write the Price heading '************************* Kluge ******************************* If (tabb = "raw") Then Worksheets(tabb).Cells(161, 1) = "Price" Worksheets(tabb).Cells(161, 2) = Worksheets(crittab).Cells(43, 13) End If If (tabb = "rawmob") Then Worksheets(tabb).Cells(183, 1) = "Price" Worksheets(tabb).Cells(183, 2) = Worksheets(crittab).Cells(43, 13) End If '************************* Kluge ******************************** 'write out the evaluators names For i = 1 To 10 ' changed from nE so as to overwrite old names Worksheets(tabb).Cells(2 + i, 2) = Worksheets(evaltab).Cells((3 + i), 2) Next i 'write out the options headings For i = 1 To 10 'same as above nO OptionHeading = "Option " & i & " - " & Worksheets(evaltab).Cells((3 + i), 10) Worksheets(tabb).Cells(optnrow(i), 1) = OptionHeading Next i ' write out the bidder names For i = 1 To 10 ' changed from nB Worksheets(tabb).Cells(2, 3 + i) = Worksheets(evaltab).Cells((3 + i), 7) Next i '================================================================================================================================ ' get the weights of primary and secondary categories from the criterial table ' get the primary weights For p = 0 To nP px(p) = Worksheets(crittab).Cells(42 + p, 12) * 100 Next p 'get the secondary weights For p = 1 To nP ' loop through the primaries and get the seondaries nScats(p) = 0 ' set the number of secondaries per primary to 0 (used in the next step) For s = 1 To nS ' loop through the secondaries ps(p, s) = Worksheets(crittab).Cells((row1 - 1 + s), (com1 - 1 + p)) ' get the proper secondary weight from the category table Next s Next p 'determine the number of secondaries categories fro each Primary category For p = 1 To nP ' loop through the primaries and get the seondaries For s = 1 To nS ' loop through the secondaries If (ps(p, s) <> 0) Then nScats(p) = nScats(p) + 1 Next s Next p '================================================================================================================================ 'This module (type "one") reads in all of the raw scores provided by the evaluator and creates some arrays that are used in late calculations. 'this is for use in a single evaluators sheet 'There is one 3 dimensional array for every evaluator 'The created arrays are for: common Primary and Secondary categories .. for each bid. ' 1- rifsum: The sum of the RIF's ' 2- scosum: The sum of the scores ' 3- numsco: The number if items scored ' 4- scored: A flag indicating that the P and S (for that bid) was scored at all If (usetype = "one") Then For l = 5 To nL ' Loop as long as ther are valid lines ( hard coded) For e = 1 To nE ' loop for every evaluator If Worksheets("Scorecard").Cells(l, 2) = "y" And mytab = "RESULTS" And Worksheets("Scorecard").Cells(l, 4) <= 2 Then ' Only process if the cell is scored (L,2) is location of score flag p = Worksheets("Scorecard").Cells(l, 10) ' get the primary category from column 10 s = Worksheets("Scorecard").Cells(l, 11) ' get the secondary criteria from column 11 rif = Worksheets("Scorecard").Cells(l, 16) ' get the RIF from column 16 For b = 1 To nB ' loop for every bid colm = scorecol1 + ((b - 1) * scoreincr) ' get the correct column for the bid ( they start at 19 and increment by 6 ) If Worksheets("Scorecard").Cells(l, colm) <> "Not Scored" Then rifsum(e, p, s, b) = rifsum(e, p, s, b) + (rif * 3) scosum(e, p, s, b) = scosum(e, p, s, b) + Worksheets("Scorecard").Cells(l, 20) * rif numsco(e, p, s, b) = numsco(e, p, s, b) + 1 scored(e, p, s, b) = "y" End If Next b End If ' if the cell is marked as scored If Worksheets("Scorecard").Cells(l, 2) = "y" And mytab <> "RESULTS" And Worksheets("Scorecard").Cells(l, 4) = optionxx Then ' Only process the option p = Worksheets("Scorecard").Cells(l, 10) ' get the primary category from column 10 s = Worksheets("Scorecard").Cells(l, 11) ' get the secondary criteria from column 11 rif = Worksheets("Scorecard").Cells(l, 16) ' get the RIF from column 16 For b = 1 To nB ' loop for every bid colm = scorecol1 + ((b - 1) * scoreincr) ' get the correct column for the bid ( they start at 19 and increment by 6 ) If Worksheets("Scorecard").Cells(l, colm) <> "Not Scored" Then rifsum(e, p, s, b) = rifsum(e, p, s, b) + (rif * 3) scosum(e, p, s, b) = scosum(e, p, s, b) + Worksheets("Scorecard").Cells(l, 20) * rif numsco(e, p, s, b) = numsco(e, p, s, b) + 1 scored(e, p, s, b) = "y" End If Next b End If ' if the cell is marked as scored Next e Next l End If '============================================================================================================================= 'This module (type "base or optn") reads in all of the raw scores provided by all of the the evaluators and creates 'arrays that are used in later calculations. 'this is for use in a consolidation evaluators sheet 'There is one 3 dimensional array for every evaluator 'The created arrays are for: common Primary and Secondary categories .. for each bid. ' 1- rifsum: The sum of the RIF's ' 2- scosum: The sum of the scores ' 3- numsco: The number if items scored ' 4- scored: A flag indicating that the P and S (for that bid) was scored at all If (usetype = "base" Or usetype = "optn") Then 'if no 001 nn = 1 Line = 4 For gp = 5 To nL + 5 For Ln = 1 To nB Line = Line + 1 'sequential line numbers starting at 5 and going up to nl*nB xline = ((gp - 5) * nB) + 5 b = Worksheets(ipfile).Cells(Line, 11) 'get the bidder for tht line 'get the prim, sec and rif data ... it is common for all bids p = Worksheets(ipfile).Cells(xline, 6) ' get the primary category from column s = Worksheets(ipfile).Cells(xline, 7) ' get the secondary criteria from column rif = Worksheets(ipfile).Cells(xline, 8) ' get the RIF from column opt = Worksheets(ipfile).Cells(xline, 2) ' the option number as assigned by team in ss 'for each evaluator, process the score For e = 1 To nE ' loop for every evaluator '--------------------------------------------------------------------------------------------------- 'Only process if the cell is scored (L,2) is location of score flag If usetype = "base" Then If opt = pri1 Or opt = pri2 Then 'if oo2 colm = allscr1 + e - 1 ' get the correct column for the bid ( they start at 23 and increment by 1 If (Worksheets(ipfile).Cells(Line, colm) <> 9) Then rifsum(e, p, s, b) = rifsum(e, p, s, b) + (rif * 3) scosum(e, p, s, b) = scosum(e, p, s, b) + Worksheets(ipfile).Cells(Line, colm) * rif numsco(e, p, s, b) = numsco(e, p, s, b) + 1 scored(e, p, s, b) = "y" End If End If ' IF the data is the basic bid .. that is not optional End If 'usetype = base '------------------------------------------------------------------------------------------------------- If usetype = "optn" Then If opt = optNo Then 'if oo2 colm = allscr1 + e - 1 ' get the correct column for the bid ( they start at 23 and increment by 1 If (Worksheets(ipfile).Cells(Line, colm) <> 9) Then rifsum(e, p, s, b) = rifsum(e, p, s, b) + (rif * 3) scosum(e, p, s, b) = scosum(e, p, s, b) + Worksheets(ipfile).Cells(Line, colm) * rif numsco(e, p, s, b) = numsco(e, p, s, b) + 1 scored(e, p, s, b) = "y" End If End If ' IF the data is the basic bid .. that is not optional End If 'usetype = base '------------------------------------------------------------------------------------------------------- Next e Next Ln Next gp End If 'If no 001 'MsgBox ("for option " & optNo & " Number scored = " & numsco(1, 3, 1, 1)) '================================================================================================================================ ' Calculate all the individual Primary and secondary score sums .. ' do the ratio division and put the results into cells ' if a person did not score a secondry category then just put an N/a in the box ' the results gives the table of scores sorted by primary and secondary For e = 1 To nE For p = 2 To nP For s = 1 To nScats(p) For b = 1 To nB If scored(e, p, s, b) = "n" Then ' this just makes sure they are set to 0 if not scored score(e, p, s, b) = 0 rifsco(e, p, s, b) = 0 End If If scored(e, p, s, b) = "y" Then 'score and rifsco are the scores per pri and sec cat score(e, p, s, b) = scosum(e, p, s, b) / rifsum(e, p, s, b) * px(p) * ps(p, s) rifsco(e, p, s, b) = rifsum(e, p, s, b) / rifsum(e, p, s, b) * px(p) * ps(p, s) End If Next b Next s Next p Next e '================================================================================================================================ 'This part places the individual data in the correct spot on the results tab If usetype = "one" Then For e = 1 To nE For p = 2 To nP 'handle all the primary categories For s = 1 To nScats(p) For b = 1 To nB If scored(e, p, s, b) = "y" Then Worksheets(tabb).Cells(s - 1 + rowstart + ((p - 2) * incr), b - 1 + colstart) = score(e, p, s, b) / 100 Else Worksheets(tabb).Cells(s - 1 + rowstart + ((p - 2) * incr), b - 1 + colstart) = "n/a" End If Next b Next s Next p Next e End If '============================================================================================================================= '---- calculate the Sub-score, max possible score and Adjusted scores --------------------- 'At this point we have x-y tables of scores for Primary and secondary categories ---------- '1st get the sum of the secondary cats. 'This is called sub-score For e = 1 To nE For p = 2 To nP For s = 1 To nScats(p) For b = 1 To nB If scored(e, p, s, b) = "y" Then 'only add up the score if it is actually scored subsco(e, p, b) = subsco(e, p, b) + score(e, p, s, b) 'This is the accumulated sum of the scores. maxsub(e, p, b) = maxsub(e, p, b) + rifsco(e, p, s, b) 'This is the accumulated sum of the perfect RIF's. num_valid_scores(e, p, b) = num_valid_scores(e, p, b) + 1 End If Next b Next s Next p Next e '==================================================================================================== 'do the adjusted score math = subscore/max possible * weight 'This is called Max possible sub-score 'MsgBox ("hallo") For e = 1 To nE For p = 2 To nP For s = 1 To nScats(p) For b = 1 To nB If scored(e, p, s, b) = "y" Then adjsco(e, p, b) = subsco(e, p, b) / maxsub(e, p, b) * px(p) 'This is the adjusted score End If Next b Next s Next p Next e 'MsgBox ("for option " & optNo & " Scored value = " & scored(1, 2, 1, 1)) '====================================================================================================== 'Print the adjusted scores 'This part places the data in the correct spot on the results tab For e = 1 To nE 'loop through all teh evaluators For p = 2 To nP 'handle all the primary categories For b = 1 To nB 'Use type = "one" If usetype = "one" Then If num_valid_scores(e, p, b) > 0 Then ' this only prints scores if at least one thing is scored Linx = rowstart + incr_ss + ((p - 2) * incr) 'puts the adjusted scores in the right place Worksheets(tabb).Cells(Linx + 0, colstart - 1 + b) = subsco(e, p, b) / 100 Worksheets(tabb).Cells(Linx + 1, colstart - 1 + b) = maxsub(e, p, b) / 100 Worksheets(tabb).Cells(Linx + 2, colstart - 1 + b) = adjsco(e, p, b) / 100 Else Worksheets(tabb).Cells(Linx + 0, colstart - 1 + b) = "n/a" ' shows n/a if nothing is scored Worksheets(tabb).Cells(Linx + 1, colstart - 1 + b) = "n/a" Worksheets(tabb).Cells(Linx + 2, colstart - 1 + b) = "n/a" End If End If 'usetype = "base" If usetype = "base" Then If num_valid_scores(e, p, b) > 0 Then ' this only prints scores if at least one thing is scored Worksheets(tabb).Cells((allrow1 + e - 1) + ((p - 2) * allincr), allcol1 + b - 1) = adjsco(e, p, b) / 100 Else Worksheets(tabb).Cells((allrow1 + e - 1) + ((p - 2) * allincr), allcol1 + b - 1) = "n/a" End If End If 'usetype = all (all evaluator) 'usetype = "optn" 'map the options acording to the RFP If usetype = "optn" Then '************************************************************************ If (ipfile = "raw") Then optionNo = optNo - 2 ' this is a cluge If (ipfile = "rawmob") Then optionNo = optNo - 15 ' this is also a cluge '************************************************************************ If num_valid_scores(e, p, b) > 0 Then ' this only prints scores if at least one thing is scored Worksheets(tabb).Cells((optnrow(optionNo) + 2 + e - 1) + ((p - 2) * allincr), allcol1 + b - 1) = adjsco(e, p, b) / 100 Else Worksheets(tabb).Cells((optnrow(optionNo) + 2 + e - 1) + ((p - 2) * allincr), allcol1 + b - 1) = "n/a" End If End If 'usetype = all (all evaluator) Next b Next p Next e '===================================================================================================== 'Lastly, Calculate the Total Percentages For e = 1 To nE For p = 2 To nP For b = 1 To nB If num_valid_scores(e, p, b) > 0 Then 'only do thi sif it makes sense totals(e, b) = adjsco(e, p, b) + totals(e, b) num_val_pri(e, b) = num_val_pri(e, b) + 1 End If Next b Next p Next e '===================================================================================================== ' Print the totals; this is just one line If usetype = "one" Then lineNo = rowstart + ((nP - 1) * incr) + 0 'calculate what line number to put it on For e = 1 To nE For b = 1 To nB If num_val_pri(e, b) = nP - 1 Then ' this only prints scores if at least one thing is scored Worksheets(tabb).Cells(lineNo, colstart - 1 + b) = totals(e, b) / 100 Else Worksheets(tabb).Cells(lineNo, colstart - 1 + b) = "n/a" ' shows n/a if nothing is scored End If Next b Next e End If 'usetype = one (one evaluator) End Sub