3

我在创建公式或 VBA 宏时遇到问题，该宏将“偏好投票”数据分类到适当的组中，供学生选择夏令营选修课。从历史上看，我们已经在纸上完成了投票和排序，我想转移到一些耗时更少的东西，以便我们在营地进行的许多轮选修课。

我创建了一个他们填写的表格，它给了我一个包含他们选修偏好的电子表格。看起来像这样

孩子们 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 想要做的是运行一个宏或（甚至更好）一个动态函数，将选民分类为类别 - 像这样

美国广播公司
1001 1002 1007
1010 1003 1008
1011 1004 1009
        1005    
        1006

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

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

如果统计数学中有一些东西可以为我指明正确的方向，那也会有所帮助。我试过用谷歌搜索这个，但我能找到的所有对投票系统的引用都假设我想匿名数据，这与我需要的相反。

我尝试了 vlookups 和索引，但公式很快变得笨拙，而且似乎并没有做我需要的事情。排序函数似乎是要走的路，但我无法理解它们的语法（仅使用视觉排序是我呈现上述排序的方式。）排名似乎没有提供我正在寻找的东西。

4

1 回答 1

4

我模拟了投票过程，并根据他们的偏好创建了以某种方式平等的孩子群体。

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

注意（免责声明呵呵）：我会只使用类型、集合和数组来完成此操作，但是演示我的解决方案的可视化表示的能力需要我使用电子表格。此示例中使用的代码可以很容易地修改为不使用电子表格而是使用集合。

这是我在步骤中所做的：

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


步骤1

注意：如果您已经有以下格式的投票结果，您可以跳过这一步和第二步：

  • 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

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

格式化的电子表格

注意：列 向下到数字（第 47 行）所以，如果你有更多的孩子，那么在继续之前添加更多的数字。A 0046


第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

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

选择列 3 变体


第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

您的示例 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

于 2013-07-24T13:38:17.777 回答