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

私ができることは、マクロを実行すること、または（さらに良い）有権者をカテゴリに分類する動的関数を実行することです-このように

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

基本的に - 選択科目 A には第 1 選択票がないため、初期カウント = 0 です。選択科目 B には第 1 選択票が 8 つあるため、最初のカウントは 8 です。選択科目 c には第 1 選択票が 3 つあるため、最初のカウントは 3 です。少なくともバランスに近い（さらに、実際には100人以上の学生がいます）ので、2番目の選択肢もあります（3番目はストライキです）. したがって、各グループの最小数は、1/4 + 1 総投票人口である必要があります。

誰が第 1 の選択肢から第 2 の選択肢に移動するかについては、本質的に主観的な選択があるため、明らかに完璧な解決策はありませんが、助けをいただければ幸いです。

統計計算に何かがあれば、私を正しい方向に向けるのにも役立ちます. 私はこれをグーグルで検索しようとしましたが、私が見つけることができる投票システムへのすべての参照は、私が必要とするものとは反対に、データを匿名化したいことを前提としています.

vlookup とインデックス作成を試みましたが、数式はすぐに扱いにくくなり、とにかく必要なことをしていないようです。SORT関数は進むべき道のようですが、それらの構文に頭を悩ませることはできません（視覚的な並べ替えを使用することは、上記の並べ替えをどのようにレンダリングしたかです.）RANKは、私が探しているものを提供していないようです.

4

1 に答える 1

4

私は投票プロセスをシミュレートし、好みの選択肢に基づいて、どういうわけか平等な子供たちのグループを作成しました。

不明な点があればコメントを残してください。内容をよりよく説明できるよう最善を尽くします。

注 (免責事項) :タイプ、コレクション、および配列のみを使用してこれを行っていましたが、ソリューションを視覚的に表現するには、スプレッドシートを使用する必要がありました。この例で使用されているコードは、スプレッドシートではなくコレクションで動作するように簡単に変更できます。

これが私が段階的に行ったことです：

  • 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

スプレッドシートは次のスクリーンショットのようになります

フォーマットされたスプレッドシート

注:列 は番号(行 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

この時点で、スプレッドシートに戻り、次の結果が得られるはずです。

無作為投票

注: 上記の形式で投票結果が既にある場合は、この手順をスキップできると言いました。 動作を確認するためだけに、すべての手順に従うことをお勧めします。


Step3

新しい を追加し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 )
  • 優先度が最も高いグループを見つける
  • リストの最初のものを取得します [リストの最後から開始] (そのため、列の順序をランダム化することをお勧めします)
  • 子供の 2 番目の選択肢を見つけて、その列に移動します

例えば：

説明

グループ B は最も優先度の高いグループであるため、他の人を均等にするために、一部の人をグループから外す必要があります。

毎回、グループのサイズを確認する必要があります。彼らがお互いに近づくと、私たちは子供たちを動かしなくなります。

最初の子供を取り上げて0001、2 番目に選んだ子供が最低のグループかどうかを確認します。それが false の場合は、次のグループに移動し、2 番目に選択した 1 人の子供が最下位のグループ (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 に答える