excel - 首选项将数据投票给组

Question

我在创建公式或VBA宏时遇到问题，该宏将“优先投票”数据分类为适合选择夏令营选修课的学生的适当组。从历史上看，我们在纸上进行投票和排序，对于我们在营地进行的许多轮选修课，我想花一些时间来减少时间。

香港专业教育学院创建了一个他们填写的表格，这给了我一个带有其选择偏好的电子表格。看起来像这样

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


id想要做的是运行一个宏或（甚至更好的）一个动态功能，将选民分为几类-像这样

A B C
1001 1002 1007
1010 1003 1008
1011 1004 1009
1005
1006


基本上-选票A没有优先选择票，因此其初始票数=0。选票B有8个优先选择票，因此其初始票数是8，选民c拥有3个优先选择票，因此其初始票数是3。至少接近平衡（加我实际上有100多名学生），所以我们也有第二选择（第三是罢工）。因此每组的最低人数需要为1/4 + 1总投票人数。

显然，没有任何解决方案是完美的，因为对于谁从第一选择转移到第二选择存在着内在的主观选择，但任何帮助都将不胜感激。

如果统计数学中有什么可以为我指出正确的方向，那也会有所帮助。香港专业教育学院尝试谷歌搜索，但我能找到的所有对投票系统的引用都假设我想匿名化数据，这与我所需要的相反。

香港专业教育学院尝试了vlookups和索引，但公式很快变得笨拙，而且似乎也无法满足我的需要。 SORT函数似乎是行之有效的方法，但是我无法将其语法缠住（仅使用视觉排序就可以实现上述排序。）RANK似乎没有提供我想要的东西。

Answer 1

我模拟了投票过程，并根据他们的偏好选择创建了几组相等的孩子。

如果有任何不清楚的地方，请发表评论，我会尽力更好地解释内容。

注意（免责声明）：我本可以仅使用类型，集合和数组来完成此操作，但是要演示解决方案的直观表示，需要使用电子表格。可以轻松修改此示例中使用的代码，使其不适用于电子表格，而不能与Collections一起使用。

这是我逐步完成的工作：


1-设置电子表格（电子表格名称："Sheet1"，模块名称：Formatting）
2-随机投票过程（模块名称：RandomVotes）
3-计算步骤1（模块名称：Step1）
4-计算步骤2（模块名称：Step2）




第1步

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


Kids是列A
A是列B
B是列C
C是列D


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



尽管我录制了一个宏，用于将电子表格格式化为该宏正常工作所需的标准，但是您可以手动使它看起来像这样。将以下代码复制粘贴到新模块中，并将其重命名（重命名该模块）为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

此时，返回到电子表格，它应该为您提供以下结果：



注意：我说过，如果您已经以上面指定的格式获得了投票结果，则可以跳过此步骤。我建议按照所有步骤进行操作，以了解事物的工作原理。



第三步

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

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

此代码将根据孩子的选择填充列 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

结果应类似于以下屏幕截图（如果您有随机选择，则看起来会有所不同）





第4步

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

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

此代码将重新填充列 F:H。这几乎（并且希望 ;)）实现了您所寻找的目标。

此时，您的列 F:H按孩子编号排序。要在过程中添加更多但有意的随机性，可以对数字进行重新排序。例如代替

0002
0005
0010
0013
0017
0021
0022
0025
0026
0038
0043

你可以做

0038
0005
0026
0013
0017
0022
0021
0002
0010
0025
0043

当我们了解将各组均分的算法时，您将明白我的意思。

我的解决方案使孩子们群体变得平坦：


找出每组大约有多少个孩子（总计/ 3个）
查找首选人数最高的组
[从列表的末尾开始]获得列表中的第一个（这就是为什么随机化列顺序可能是一个好主意）
找到孩子的第二选择，并将他移至该专栏


例如：



由于B组是最受青睐的组，因此我们需要将一些人从中移出，以使其他人平分秋色。

每次我们都要检查组的大小。当他们彼此靠近时，我们将停止移动孩子。

以第一个孩子 0001并检查他的第二选择是否是最低的组。如果是假的，那么我们移至下一个，直到找到一个第二个选择是最低组的孩子（在我的示例中为 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

最后结果

最终，使孩子们群体平等的最终结果是他们的选择：


我真的希望这会有所帮助！



摘要

如果您的工作表已经看起来像



然后运行 Step_1然后 Step_2



我已经为测试目的运行了几次，这是一些示例结果


您的样品

随机投票+主要分成几列。显然，它所打印的结果与您提供的示例中的结果完全不同。您已经说过没有完美的解决方案。它只有11个孩子，您说您有100个以上的孩子。我认为它可以完成工作并按预期运行

已执行 Step_1



结果



样品1

随机投票+主要分为几列

已执行 Step_1



结果



样品2

随机投票+主要分为几列

已执行 Step_1



结果



样品3

随机投票+主要分为几列

已执行 Step_1



结果