Preference Votes Data to Groups - excel

Question

I have a problem creating a formula or VBA macro that sorts 'preference voting' data into appropriate groups for students selecting summer camp electives. Historically, we've done the voting and sorting on paper, and i'd like to move to something a little less time consuming for the many, many rounds of electives we do at camp.
Ive created a form they fill out, which gives me a spreadsheet with their elective preferences. it looks like this
Kids A 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 like to be able to do is run a macro or (even better) a dynamic function that sorts the voters into categories - like this
A B C
1001 1002 1007
1010 1003 1008
1011 1004 1009
1005
1006
basically - elective A has no first choice votes so its initial count = 0. Elective B has 8 first choice votes, so its initial count is 8, elective c has 3 first choice votes so its initial count is 3. I need these to be at least close to balanced (plus i actually have over 100 students), so we have 2nd choices also (3rd is a strike). so the minimum count for each group needs to be 1/4 + 1 total voting population.
Obviously no solution is perfect, because theres an inherently subjective choice about who gets moved from their first choice to their second, but any help would be appreciated.
If theres something in stat math that would point me in the right direction that would help too. ive tried googling this, but all references to voting systems i can find assume i want to anonymise the data, which is the opposite of what i need.
ive tried vlookups and indexing, but the formulas quickly get unwieldy, and dont seem to do what i need anyway. SORT functions seem to be the way to go, but i cant wrap my head around the syntax of them (using just visual sort is how ive rendered the above sorting.) RANK doesnt seem to offer what im looking for.

Answer 1

I have simulated the voting process and created somehow equal groups of kids based on their preferred choices.
If anything is unclear please leave a comment and I will do my best to better explain the content.
Note(disclaimer hehe): I would have done this using only Types, Collections and arrays, however the ability to demonstrate visual representation of my solution required me to use spreadsheet. The code used in this example can easily be modified not to work with spreadsheets but Collections.
Here's what I 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 this step and step2 if you already have the results of voting in the following format:
Kids is column A
A is column B
B is column C
C is column D
Your initial spreadsheet should look like the below screenshot
You can manually make it look like this although I have recorded a macro that formats your spreadsheet to the standards required for the macro to work properly. Copy-paste the below code to a new module and rename it(rename the module) to Formatting execute the below code(press F5 to execute)
Sub FormatSpreadsheet()
Application.ScreenUpdating = False
Cells.Select
With 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 With
With 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 With
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
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Columns("A:P").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
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
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.14996795556505
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ThemeColor = 1
.TintAndShade = -0.14996795556505
.Weight = xlThin
End With
Range("B1:D1,F1:H1,J1:L1,N1:P1").Select
Range("N1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A1").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
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
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = -0.249977111117893
.PatternTintAndShade = 0
End With
Range("E1:H1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
.TintAndShade = 0.399975585192419
.PatternTintAndShade = 0
End With
Range("I1:L1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E1:H1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent4
.TintAndShade = 0.599993896298105
.PatternTintAndShade = 0
End With
Range("M1:P1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 13434879
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("E1,I1,M1").Select
Range("M1").Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlEdgeTop).LineStyle = xlNone
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Range("A1").Select
Application.ScreenUpdating = True
End Sub
You spreadsheet now should like like the below screenshot
Note: column A goes down to number 0046 (row 47) so, if you have more kids then add more numbers before continuing.
Step 2
Add a new Module and name it RandomVotes
Copy-Paste and then execute (F5) the code to get results.
The code will simulate a voting process and print results in columns B to D:
Sub RandomizeVotes()
Application.ScreenUpdating = False
Dim i As Long, j As Long
Dim r As Range, nxtRnd As Long
Dim rowComplete As Boolean
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("B" & i)
r = GetRandom
Do Until rowComplete
r.Offset(0, 1) = GetRandom
r.Offset(0, 2) = GetRandom
If r <> r.Offset(0, 1) And r <> r.Offset(0, 2) And r.Offset(0, 1) <> r.Offset(0, 2) Then rowComplete = True
Loop
Set r = Nothing
rowComplete = False
Next i
Application.ScreenUpdating = True
End Sub
Function GetRandom() As Long
Randomize
Dim x As Double
x = Rnd
If x < 0.3 Then
GetRandom = 1
ElseIf x >= 0.3 And x < 0.6 Then
GetRandom = 2
ElseIf x >= 0.6 Then
GetRandom = 3
End If
End Function
At this point, go back to your spreadsheet it should give you the following results:
Note: I said you can skip this step if you already have your voting results in the format specified above. I would recommend following all steps just to see how things work.
Step3
Add a new Module, name it Step1.
Copy-Paste the below code and again: execute it.
This code will populate columns F:P based on kids choices
Option Explicit
' Choices columns
Sub Step_1()
Dim i As Long
Dim r As Range
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
Set r = Range("B" & i)
' first choices
If r = 1 Then
r.Offset(0, 4) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 1) = 1 Then
r.Offset(0, 5) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 2) = 1 Then
r.Offset(0, 6) = r.Offset(0, -1).Text
End If
' second choices
If r = 2 Then
r.Offset(0, 8) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 1) = 2 Then
r.Offset(0, 9) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 2) = 2 Then
r.Offset(0, 10) = r.Offset(0, -1).Text
End If
' third choices
If r = 3 Then
r.Offset(0, 12) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 1) = 3 Then
r.Offset(0, 13) = r.Offset(0, -1).Text
ElseIf r.Offset(0, 2) = 3 Then
r.Offset(0, 14) = r.Offset(0, -1).Text
End If
Set r = Nothing
Next i
deleteEmpties
End Sub
Private Sub deleteEmpties()
Application.ScreenUpdating = False
Dim i As Long, j As Long
For i = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
For j = 16 To 6 Step -1
If IsEmpty(Cells(i, j)) Then Cells(i, j).Delete Shift:=xlUp
Next j
Next i
Application.ScreenUpdating = False
End Sub
The result should look similar to the below screenshot (if you have randomized choices than it will look different)
Step 4
Add a new Module, name it Step2.
Copy-Paste the below code and again: execute it.
This code will re-populate columns F:H. This pretty much (and hopefully ;) ) achieves what you were looking for.
At this point, your column F:H are sorted by kids numbers. To add more although intentional randomness to the process you can re-sort the numbers. For example instead of
0002
0005
0010
0013
0017
0021
0022
0025
0026
0038
0043
you can do
0038
0005
0026
0013
0017
0022
0021
0002
0010
0025
0043
You will see what I mean when we get to the algorithm that will even out the groups.
My solution to even out the groups of kids:
find out roughly how many kids per group ( total / 3 )
find group with the highest preferred count
get the first in the list [starting from the end of the list] (thats why randomizing columns order may be a good idea)
find kid's second choice and move him to that column
for example:
Since the group B is the highest preferred group we need to move some people off of it in order to even out the other ones.
Each time we have to check the size of groups. Once they come close to each other we stop moving kids around.
Take the first kid 0001 and check whether his 2nd choice is the lowest group. If it's a false then we move to the next one, and keep moving until we find one kid who's second choice is the lowest group (A in my example ).
'0011' and '0012' match our criteria so we can move them to the lowest group.
Checking for the length of the size of the most preferred group again.
and so on results in this Step2 Module code:
Option Explicit
Type Group
Name As String
Column As String
Size As Long
End Type
Type Number
Total As Long
Average As Long
HiBound As Long
LoBound As Long
End Type
Type Child
Id As String
Choice1 As String
Choice2 As String
Choice3 As String
End Type
Public A As Group
Public B As Group
Public C As Group
' moving based on the second preference
Sub Step_2()
Dim T As 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 i As Long, j As Long, k As Long
Dim kidChoice As Range, kidId As Range
For i = Range("" & getBiggest.Column & "" & Rows.Count).End(xlUp).Row To 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 _
Then
Exit For
Else
For k = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
Set kidChoice = Range("" & getBiggest.Column & "" & i)
Set kidId = Range("A" & k)
Dim kid As Child
kid.Id = kidId.Text
kid.Choice1 = getBiggest.Name
If StrComp(kidChoice.Text, kidId.Text, 1) = 0 Then
For j = 1 To 3
If kidId.Offset(0, j) = 2 Then
kid.Choice2 = Cells(1, j + 1).Text
End If
If kidId.Offset(0, j) = 3 Then
kid.Choice3 = Cells(1, j + 1).Text
End If
Next j
If kid.Choice2 = getSmallest.Name Then
' transfer groups
Dim nxtSmall As 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 i
End Sub
Private Function getBiggest() As Group
If A.Size > B.Size And A.Size > C.Size Then
getBiggest = A
ElseIf B.Size > A.Size And B.Size > C.Size Then
getBiggest = B
ElseIf C.Size > A.Size And C.Size > B.Size Then
getBiggest = C
ElseIf A.Size = B.Size Or A.Size = C.Size Then
getBiggest = A
ElseIf B.Size = A.Size Or B.Size = C.Size Then
getBiggest = B
ElseIf C.Size = A.Size Or C.Size = B.Size Then
getBiggest = C
End If
End Function
Private Function getSmallest() As Group
If A.Size < B.Size And A.Size < C.Size Then
getSmallest = A
ElseIf B.Size < A.Size And B.Size < C.Size Then
getSmallest = B
ElseIf C.Size < A.Size And C.Size < B.Size Then
getSmallest = C
ElseIf A.Size = B.Size Or A.Size = C.Size Then
getSmallest = A
ElseIf B.Size = A.Size Or B.Size = C.Size Then
getSmallest = B
ElseIf C.Size = A.Size Or C.Size = B.Size Then
getSmallest = C
End If
End Function
Final result
And the final result of the equating the groups of kids preferred choices:
I really hope this helps!
Summary
If your sheet already looks like
then run Step_1 and then Step_2
I have ran this a few times for testing purposes, here are some sample results
Your sample
Random Votes + primary split into columns . Obviously, it isn't printing exactly the same results as you provided in your sample. You have already said there is no perfect solution. its ran on only 11 kids and you have said you have 100+. I think it does the job though and functions as expected
executed Step_1
Result
Sample 1
Random Votes + primary split into columns
executed Step_1
Result
Sample 2
Random Votes + primary split into columns
executed Step_1
Result
Sample 3
Random Votes + primary split into columns
executed Step_1
Result