excel - Preference Votes Data to Groups -
i have problem creating formula or vba macro sorts 'preference voting' data appropriate groups students selecting summer camp electives. historically, we've done voting , sorting on paper, , i'd move little less time consuming many, many rounds of electives @ camp.
ive created form fill out, gives me spreadsheet elective preferences. looks
kids b c 1001 2 3 1 1002 3 1 2 1003 3 1 2 1004 3 1 2 1005 3 1 2 1006 3 1 2 1007 3 2 1 1008 3 2 1 1009 2 1 3 1010 3 1 2 1011 2 1 3
what id able run macro or (even better) dynamic function sorts voters categories - this
b c 1001 1002 1007 1010 1003 1008 1011 1004 1009 1005 1006
basically - elective has no first choice votes initial count = 0. elective b has 8 first choice votes, initial count 8, elective c has 3 first choice votes initial count 3. need these @ least close balanced (plus have on 100 students), have 2nd choices (3rd strike). minimum count each group needs 1/4 + 1 total voting population.
obviously no solution perfect, because theres inherently subjective choice gets moved first choice second, appreciated.
if theres in stat math point me in right direction too. ive tried googling this, references voting systems can find assume want anonymise data, opposite of need.
ive tried vlookups , indexing, formulas unwieldy, , dont seem need anyway. sort functions seem way go, cant wrap head around syntax of them (using visual sort how ive rendered above sorting.) rank doesnt seem offer im looking for.
i have simulated voting process , created somehow equal groups of kids based on preferred choices.
if unclear please leave comment , best better explain content.
note(disclaimer hehe): i have done using types, collections , arrays, ability demonstrate visual representation of solution required me use spreadsheet. code used in example can modified not work spreadsheets collections.
here's have done in steps:
- 1 - setup spreadsheet (spreadsheet name:
"sheet1", module name:formatting) - 2 - randomized voting process (module name:
randomvotes) - 3 - calculations step 1 (module name:
step1) - 4 - calculations step 2 (module name:
step2)
step 1
note: you can skip step , step2 if have results of voting in following format:
kidscolumnaacolumnbbcolumncccolumnd
your initial spreadsheet should below screenshot
you can manually make although have recorded macro formats spreadsheet standards required macro work properly. copy-paste below code new module , rename it(rename module) formatting execute below code(press f5 execute)
sub formatspreadsheet() application.screenupdating = false cells.select selection.font .name = "consolas" .size = 10 .strikethrough = false .superscript = false .subscript = false .outlinefont = false .shadow = false .underline = xlunderlinestylenone .themecolor = xlthemecolorlight1 .tintandshade = 0 .themefont = xlthemefontnone end selection.font .name = "consolas" .size = 10 .strikethrough = false .superscript = false .subscript = false .outlinefont = false .shadow = false .underline = xlunderlinestylenone .themecolor = xlthemecolorlight1 .tintandshade = 0 .themefont = xlthemefontnone end range("a1").select activecell.formular1c1 = "kids" range("b1").select activecell.formular1c1 = "a" range("c1").select activecell.formular1c1 = "b" range("d1").select activecell.formular1c1 = "c" range("a2").select activecell.formular1c1 = "1" cells.select selection.numberformat = "@" range("a2").select activecell.formular1c1 = "0001" range("a3").select activecell.formular1c1 = "0002" range("a4").select activecell.formular1c1 = "0003" range("a2:a4").select selection.autofill destination:=range("a2:a47"), type:=xlfilldefault range("a2:a47").select range("b1:d1").select selection.interior .pattern = xlsolid .patterncolorindex = xlautomatic .color = 65535 .tintandshade = 0 .patterntintandshade = 0 end selection.interior .pattern = xlsolid .patterncolorindex = xlautomatic .themecolor = xlthemecoloraccent1 .tintandshade = 0.399975585192419 .patterntintandshade = 0 end columns("a:p").select selection .horizontalalignment = xlgeneral .verticalalignment = xlcenter .wraptext = false .orientation = 0 .addindent = false .indentlevel = 0 .shrinktofit = false .readingorder = xlcontext .mergecells = false end selection .horizontalalignment = xlcenter .verticalalignment = xlcenter .wraptext = false .orientation = 0 .addindent = false .indentlevel = 0 .shrinktofit = false .readingorder = xlcontext .mergecells = false end range("b1:d1").select selection.copy range("f1").select activesheet.paste range("j1").select activesheet.paste range("n1").select activesheet.paste range("h7").select application.cutcopymode = false range("b:d,f:f,g:g,h:h,j:j,k:k,l:l,n:n,o:o,p:p").select range("p1").activate selection.borders(xldiagonaldown).linestyle = xlnone selection.borders(xldiagonalup).linestyle = xlnone selection.borders(xledgeleft) .linestyle = xlcontinuous .colorindex = xlautomatic .tintandshade = 0 .weight = xlthin end selection.borders(xledgetop) .linestyle = xlcontinuous .colorindex = xlautomatic .tintandshade = 0 .weight = xlthin end selection.borders(xledgebottom) .linestyle = xlcontinuous .themecolor = 1 .tintandshade = -0.14996795556505 .weight = xlthin end selection.borders(xledgeright) .linestyle = xlcontinuous .colorindex = xlautomatic .tintandshade = 0 .weight = xlthin end selection.borders(xlinsidevertical) .linestyle = xlcontinuous .colorindex = xlautomatic .tintandshade = 0 .weight = xlthin end selection.borders(xlinsidehorizontal) .linestyle = xlcontinuous .themecolor = 1 .tintandshade = -0.14996795556505 .weight = xlthin end range("b1:d1,f1:h1,j1:l1,n1:p1").select range("n1").activate selection.borders(xldiagonaldown).linestyle = xlnone selection.borders(xldiagonalup).linestyle = xlnone selection.borders(xledgeleft) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xledgetop) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xledgebottom) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xledgeright) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xlinsidevertical) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xlinsidehorizontal) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end range("a1").select selection.borders(xldiagonaldown).linestyle = xlnone selection.borders(xldiagonalup).linestyle = xlnone selection.borders(xledgeleft).linestyle = xlnone selection.borders(xledgetop).linestyle = xlnone selection.borders(xledgebottom) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xledgeright) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xlinsidevertical).linestyle = xlnone selection.borders(xlinsidehorizontal).linestyle = xlnone range("e1").select activecell.formular1c1 = "1st choice" range("i1").select activecell.formular1c1 = "2nd choice" range("m1").select activecell.formular1c1 = "3rd choice" range("e:e,i:i,m:m").select range("m1").activate selection.columnwidth = 12.13 range("e1:h1").select selection.interior .patterncolorindex = xlautomatic .themecolor = xlthemecoloraccent3 .tintandshade = -0.249977111117893 .patterntintandshade = 0 end range("e1:h1").select selection.interior .pattern = xlsolid .patterncolorindex = xlautomatic .themecolor = xlthemecoloraccent5 .tintandshade = 0.399975585192419 .patterntintandshade = 0 end range("i1:l1").select selection.interior .patterncolorindex = xlautomatic .color = 15773696 .tintandshade = 0 .patterntintandshade = 0 end range("e1:h1").select selection.interior .pattern = xlsolid .patterncolorindex = xlautomatic .themecolor = xlthemecoloraccent4 .tintandshade = 0.599993896298105 .patterntintandshade = 0 end range("m1:p1").select selection.interior .patterncolorindex = xlautomatic .color = 13434879 .tintandshade = 0 .patterntintandshade = 0 end range("e1,i1,m1").select range("m1").activate selection.borders(xldiagonaldown).linestyle = xlnone selection.borders(xldiagonalup).linestyle = xlnone selection.borders(xledgeleft) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xledgetop).linestyle = xlnone selection.borders(xledgebottom) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xledgeright) .linestyle = xlcontinuous .colorindex = 0 .tintandshade = 0 .weight = xlthin end selection.borders(xlinsidevertical).linestyle = xlnone selection.borders(xlinsidehorizontal).linestyle = xlnone range("a1").select application.screenupdating = true end sub you spreadsheet should like below screenshot
note: column a goes down number 0046 (row 47) so, if have more kids add more numbers before continuing.
step 2
add new module , name randomvotes
copy-paste , execute (f5) code results.
the code simulate voting process , print results in columns b d:
sub randomizevotes() application.screenupdating = false dim long, j long dim r range, nxtrnd long dim rowcomplete boolean = 2 range("a" & rows.count).end(xlup).row set r = range("b" & i) r = getrandom until rowcomplete r.offset(0, 1) = getrandom r.offset(0, 2) = getrandom if r <> r.offset(0, 1) , r <> r.offset(0, 2) , r.offset(0, 1) <> r.offset(0, 2) rowcomplete = true loop set r = nothing rowcomplete = false next application.screenupdating = true end sub function getrandom() long randomize dim x double x = rnd if x < 0.3 getrandom = 1 elseif x >= 0.3 , x < 0.6 getrandom = 2 elseif x >= 0.6 getrandom = 3 end if end function at point, go spreadsheet should give following results:
note: i said can skip step if have voting results in format specified above. recommend following steps see how things work.
step3
add new module, name step1.
copy-paste below code , again: execute it.
this code populate columns f:p based on kids choices
option explicit ' choices columns sub step_1() dim long dim r range = 2 range("a" & rows.count).end(xlup).row set r = range("b" & i) ' first choices if r = 1 r.offset(0, 4) = r.offset(0, -1).text elseif r.offset(0, 1) = 1 r.offset(0, 5) = r.offset(0, -1).text elseif r.offset(0, 2) = 1 r.offset(0, 6) = r.offset(0, -1).text end if ' second choices if r = 2 r.offset(0, 8) = r.offset(0, -1).text elseif r.offset(0, 1) = 2 r.offset(0, 9) = r.offset(0, -1).text elseif r.offset(0, 2) = 2 r.offset(0, 10) = r.offset(0, -1).text end if ' third choices if r = 3 r.offset(0, 12) = r.offset(0, -1).text elseif r.offset(0, 1) = 3 r.offset(0, 13) = r.offset(0, -1).text elseif r.offset(0, 2) = 3 r.offset(0, 14) = r.offset(0, -1).text end if set r = nothing next deleteempties end sub private sub deleteempties() application.screenupdating = false dim long, j long = range("a" & rows.count).end(xlup).row 2 step -1 j = 16 6 step -1 if isempty(cells(i, j)) cells(i, j).delete shift:=xlup next j next application.screenupdating = false end sub the result should similar below screenshot (if have randomized choices different)
step 4
add new module, name step2.
copy-paste below code , again: execute it.
this code re-populate columns f:h. this pretty (and ;) ) achieves looking for.
at point, column f:h sorted kids numbers. add more although intentional randomness process can re-sort numbers. example instead of
0002 0005 0010 0013 0017 0021 0022 0025 0026 0038 0043 you can
0038 0005 0026 0013 0017 0022 0021 0002 0010 0025 0043 you see mean when algorithm out groups.
my solution out groups of kids:
- find out how many kids per group ( total / 3 )
- find group highest preferred count
- get first in list [starting end of list] (thats why randomizing columns order may idea)
- find kid's second choice , move him column
for example:
since group b highest preferred group need move people off of in order out other ones.
each time have check size of groups. once come close each other stop moving kids around.
take first kid 0001 , check whether 2nd choice lowest group. if it's false move next one, , keep moving until find 1 kid who's second choice lowest group (a in example ).
'0011' , '0012' match our criteria can move them lowest group.
checking length of size of preferred group again.
and on results in step2 module code:
option explicit type group name string column string size long end type type number total long average long hibound long lobound long end type type child id string choice1 string choice2 string choice3 string end type public group public b group public c group ' moving based on second preference sub step_2() dim t number a.name = "a" a.column = "f" a.size = range("f" & rows.count).end(xlup).row b.name = "b" b.column = "g" b.size = range("g" & rows.count).end(xlup).row c.name = "c" c.column = "h" c.size = range("h" & rows.count).end(xlup).row t.total = range("a" & rows.count).end(xlup).row t.average = t.total / 3 t.hibound = t.average + 1 t.lobound = t.average - 1 dim long, j long, k long dim kidchoice range, kidid range = range("" & getbiggest.column & "" & rows.count).end(xlup).row 2 step -1 a.size = range("f" & rows.count).end(xlup).row b.size = range("g" & rows.count).end(xlup).row c.size = range("h" & rows.count).end(xlup).row if range("" & getbiggest.column & "" & rows.count).end(xlup).row = t.average or _ range("" & getsmallest.column & "" & rows.count).end(xlup).row = t.average _ exit else k = range("a" & rows.count).end(xlup).row 2 step -1 set kidchoice = range("" & getbiggest.column & "" & i) set kidid = range("a" & k) dim kid child kid.id = kidid.text kid.choice1 = getbiggest.name if strcomp(kidchoice.text, kidid.text, 1) = 0 j = 1 3 if kidid.offset(0, j) = 2 kid.choice2 = cells(1, j + 1).text end if if kidid.offset(0, j) = 3 kid.choice3 = cells(1, j + 1).text end if next j if kid.choice2 = getsmallest.name ' transfer groups dim nxtsmall long nxtsmall = range("" & getsmallest.column & "" & rows.count).end(xlup).row + 1 range("" & getsmallest.column & "" & nxtsmall).value = kid.id kidchoice.delete shift:=xlup end if end if set kidid = nothing next k set kidchoice = nothing end if next end sub private function getbiggest() group if a.size > b.size , a.size > c.size getbiggest = elseif b.size > a.size , b.size > c.size getbiggest = b elseif c.size > a.size , c.size > b.size getbiggest = c elseif a.size = b.size or a.size = c.size getbiggest = elseif b.size = a.size or b.size = c.size getbiggest = b elseif c.size = a.size or c.size = b.size getbiggest = c end if end function private function getsmallest() group if a.size < b.size , a.size < c.size getsmallest = elseif b.size < a.size , b.size < c.size getsmallest = b elseif c.size < a.size , c.size < b.size getsmallest = c elseif a.size = b.size or a.size = c.size getsmallest = elseif b.size = a.size or b.size = c.size getsmallest = b elseif c.size = a.size or c.size = b.size getsmallest = c end if end function final result
and final result of equating groups of kids preferred choices: 
i hope helps!
summary
if sheet looks
then run step_1 , step_2
i have ran few times testing purposes, here sample results
your sample
random votes + primary split columns . obviously, isn't printing same results provided in sample. have said there no perfect solution. ran on 11 kids , have said have 100+. think job though , functions expected
executed step_1
result
sample 1
random votes + primary split columns
executed step_1
result
sample 2
random votes + primary split columns
executed step_1
result
sample 3
random votes + primary split columns
executed step_1
result
Comments
Post a Comment