Preference Votes Data to Groups

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…

Accepted Answer

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…

Preference Votes Data to Groups

Solution

Problem