首选项将数据投票到组

创build公式或VBAmacros时出现问题，将“偏好投票”数据分类为适合select夏令营选修课的学生组。 从历史上看，我们已经完成了纸面上的投票和sorting工作，而且我希望能够在营地做很多很多选修课的时候减less一点时间。

我创build了一个他们填写的表单，这给了我一个电子表格与他们的select偏好。 它看起来像这样 

孩子们的ABC
 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

id能够做的就是运行一个macros，或者（甚至更好）一个dynamic的函数，把选民分类成不同的类别 – 就像这样 

 ABC
 1001 1002 1007
 1010 1003 1008
 1011 1004 1009
         1005    
         1006

基本上 – 选修A没有首选选票，所以它的初始计数= 0。选修B有8个首选选票，所以它的初始计数是8，选修c有3个第一select票，所以它的初始计数是3。至less接近平衡（加上我实际上有超过100个学生），所以我们也有第二select（第三是罢工）。 所以每个小组的最小计数必须是总投票人口的1/4 + 1。

显然没有解决scheme是完美的，因为这是一个天生的主观select，谁是从他们的第一select移到第二，但任何帮助，将不胜感激。

如果在math上有些东西会使我指向正确的方向，那也是有帮助的。 我试着用Googlesearch这个，但是我可以find所有的投票系统的参考，假设我想匿名数据，这是我需要的相反。

香港专业教育学院尝试vlookups和索引，但公式很快变得笨拙，似乎并没有做我所需要的东西。 sorting函数似乎是要走的路，但我不能包围我的头他们的语法（使用视觉sorting是如何呈现上述sorting）。排名似乎并没有提供什么即时通讯寻找。

我已经模拟了投票过程，并根据他们的首选select创build了一些平等的小孩群体。

如果有什么不清楚的地方，请留下评论，我会尽我所能来更好地解释内容。

注意（免责声明hehe） ： 我只能使用types，集合和数组，但是展示我的解决scheme的可视化表示的能力要求我使用电子表格。 在这个例子中使用的代码可以很容易地修改，不用电子表格而是集合。

以下是我所做的步骤：

  • 1 – 设置电子表格（ 电子表格名称： "Sheet1" ， 模块名称 ： Formatting ）
  • 2 – 随机表决程序（ 模块名称： RandomVotes ）
  • 3 – 计算步骤1（ 模块名称：步骤1）
  • 4 – 计算步骤2（ 模块名称： Step2 ）

步骤1

注意 ： 如果您已经具有以下格式的投票结果，则可以跳过此步骤和步骤2 ：

  • Kids是专栏A
  • A是B列
  • B是C列
  • C是D列

您的初始电子表格应该如下图所示

建立

您可以手动将它看起来像这样，虽然我已经logging了一个macros，它将您的电子表格格式化为macros所需的标准以正常工作。 复制粘贴下面的代码到一个新的模块，并将其重命名（ 重命名模块 ） Formatting执行下面的代码（ 按 F5执行） 

 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

你现在的电子表格应该像下面的截图一样

格式化的电子表格

注意 ： 列 A 下降到编号 0046 （ 行47 ）， 所以，如果你有更多的孩子，然后再继续添加更多的数字。

第2步

添加一个新Module并将其命名为RandomVotes

复制粘贴，然后执行（ F5 ）代码来获得结果。

代码将模拟投票过程并在列B到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

在这一点上，回到你的电子表格应该给你以下结果：

随机表决

注意： 我说过，如果你已经有了上面指定格式的投票结果，你可以跳过这一步。 我会build议遵循所有步骤来看看 事情是如何工作的 。

第三步：

添加一个新的Module ，将其命名为Step1 。

复制粘贴下面的代码并再次执行：执行它。

这段代码会 根据孩子的select 填充 F:P 列 

 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

结果应该看起来类似于下面的截图（ 如果你有随机select比看起来不同 ）

选择列3变化

步骤4

添加一个新的Module ，将其命名为Step2 。

复制粘贴下面的代码并再次执行：执行它。

这段代码将重新填充列 F:H 。 这非常（并希望;) ） 实现你在找什么 。

在这一点上，你的专栏F:H是按小孩数字sorting的。 要添加更多，虽然有意识的随机性的过程中，你可以重新sorting的数字。 例如，而不是 

 0002 0005 0010 0013 0017 0021 0022 0025 0026 0038 0043

你可以做 

 0038 0005 0026 0013 0017 0022 0021 0002 0010 0025 0043

当我们看到algorithm甚至是团队的时候，你会明白我的意思。

我的解决scheme，以平衡团体的孩子们：

  • 大概找出每个小组有多less个孩子（总数/ 3）
  • find具有最高首选计数的组
  • 列表中的第一个[ 从列表的末尾开始 ]（ 这就是为什么随机化列顺序可能是一个好主意 ）
  • find孩子的第二select，并将他移动到该列

例如：

说明

由于B组是最优选的组，所以我们需要移动一些人来平衡其他人。

每次我们都要检查组的大小。 一旦彼此接近，我们就停止向周围的小孩移动。

拿第一个孩子0001 ，检查他的第二个select是否是最低的组。 如果这是一个错误，那么我们移动到下一个，并继续前进，直到我们发现一个第二select的孩子是最低的组（在我的例子中是A ）。

'0011'和'0012'符合我们的标准，所以我们可以将它们移动到最低的组。

再次检查最优选组的大小的长度。

等Step2结果Module代码： 

 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

最后结果

最后的结果是把孩子们的群体等同为首选的select： 最后结果

我真的希望这有助于！

概要

如果你的表已经看起来像

建立

然后运行Step_1 ，然后运行Step_2

为了testing目的我已经跑了几次，下面是一些示例结果

你的样品

随机表决+主要拆分成列。 显然，它不会打印出与您在样本中提供的结果完全相同的结果。 你已经说过没有完美的解决scheme。 它只跑了11个孩子，你说你有100多个。 我认为它做的工作虽然和预期的function

执行Step_1

你的样品Step_1

结果

您的示例Step_2

样品1

随机表决+主要拆分成列

执行Step_1

样本1执行step_1

结果

样本1的结果

样品2

随机表决+主要拆分成列

执行Step_1

样本2执行step_1

结果

样本2结果执行step_2

样品3

随机表决+主要拆分成列

执行Step_1

样本3执行step_1

结果

样本3的结果执行step_2

Interesting Posts

制表符分隔的数据集中拼写的统计描述

在Excel中build立等级联系以进行Mann-Whitney U检验

从特定数字（本福特定律）开始计数事件

你如何在列中分组数据？

Excel / VBA中的大型数据集的多条件统计（平均值，标准差，z值）

学生在C ++中的T分布

计算excel中spearman排名统计的p值（使用vba或不使用vb​​a）

Excel 2016 – 如何确定我应该使用哪一列来帮助我预测实际数字？

Excel公式：计算调查统计

为什么这个Excel公式有效？