[[20061225182121]]　『組み合わせ』（teni）　ページの最後に飛ぶ

『組み合わせ』（teni）
２人対２人の試合の組合せなんですが、参加人数によってランダムな組み合わせを求めるのはどうしたらいいんでしょうか？

 ５人の場合
 １試合目：1と2 3と4　（５は休憩）
 ２試合目：2と3 4と5
 　　　　・
 　　　　・
 　　　　・
 　　　　・
 　　　　・
 　　　　・
 みたいな。

 例えばこんなのはどうですか？

 Ａのセルに試合の番号と組み合わせを入れておきます。
 Ｂのセルに参加者の名前を全て入れます。
 Ｃのセルには関数として=RAND()を参加者の人数分入れます。
 （これは、Ｃ１のセルに=RAND()と入力しそのままマウスをＣ１セルの右下の
 　合わせるとカーソルが十時になるのでそこでダブルクリックすればＯＫです）

     A      B         C
 1 １Ａ  小山さん  =RAND()
 2 １Ａ  山田さん  =RAND()
 3 １Ｂ  中村さん  =RAND()
 4 １Ｂ  中村さん  =RAND()
 5       村上さん  =RAND()
 6

 ここまで出来たらＢとＣのセルを２列とも選択し、メニューの
 「データ」－＞「並び替え」で「最優先されるキー」をＣ列に
 してＯＫをクリックするとＢ列の順番がバラバラなるので、
 Ａのセルに試合番号が入っている人が試合がある人で、ない人は
 休憩って感じですね。

 それと、一度ＢとＣのセルを選択した状態で、再度並び替えを
 行なうと、違う組み合わせになるはずです。

 人数が８人以上になったら、Ａ列に「２Ａ」とか「２Ｂ」を入れて
 やれば使えます。

 自動でＡ列に値を入れるのは関数でも出来そうですけど、とりあえず
 考え方としてはこんなもんでどうでしょうか？

 （こいん）

コメントありがとうございます。できれば下記のような簡単な感じにしたいのですが、やはりマクロに足をつっこんしまわないとだめですかね？人数を入力するとずらずらーーと組合せがでてくる

人数入力 5人

 どのようなアルゴリズムで組み合わせを作るかが分かれば(解決すれば)それをエクセル
 に実行させることができると思いますが、皆さんそこで困っているのだと思います。
 アルゴリズムが解決しないと、マクロでも難しいでしょう。
 人数は何人ぐらいを想定していますか？
 あらかじめ人間が組み合わせを考えておくのはダメですか？
 (ちゅうねん)

 新春お遊び第１弾！（笑
 前回麻雀の組合せで役萬をあがった純丸はんも、役萬振り込んだsinしゃんもおりたみ
 たいで一向に回答がつきまへんなぁ。（笑
 これ、偶数奇数があって確たる規則性は発見でけまへんワ。
 で、まぁ、今んとこ6人以下の限定バージョンですけど試してみてくらはい。
 またヒマでけたら考えてみますけど、難しいかも・・・
 余分な作業が入ってますけど、これは6人以上を考えてのモンですから気ぃになさらず
 にネ。
 どなたか遊んでみまへんか？
 　　　　　
                （弥太郎）
 Dim dic As Object, Cnt As Integer, t As Integer, tbl
 Dim n As Integer, i As Long, p As Integer, q As Integer, x As Integer

 Sub 組合せ()
    Dim data As Integer
    Dim m As Integer, y As Integer, num As Long, ary
    Dim v As Integer, w As Integer, u As Integer, n As Integer

    Cells.Clear
    Set dic = CreateObject("scripting.dictionary")
    data = Val(StrConv(InputBox("総人数を入力してくらはい。"), vbNarrow))
    If data = 0 Then Exit Sub
    Application.ScreenUpdating = False

    num = WorksheetFunction.Combin(data, 2)
    t = 1
    Cnt = data
    x = 1
    m = 1
    If data < 4 Then
        MsgBox "それくらいわかりまっしゃろ！"
        Exit Sub
    ElseIf data > 6 Then
        MsgBox "このマクロは未だその機能をサポートしとりまへん"
        Exit Sub
    Else
        w = WorksheetFunction.Combin(data - 2, 2)
    End If
    ReDim ary(1 To data)
    For i = 1 To data
        ary(i) = i
    Next i
    For i = 1 To num
        If i = Cnt Then
            x = x + 1
            y = y + 1
            Cnt = data + x + y
        End If
        n = n + 1
        n = IIf(i = Cnt, 1, n)
        t = IIf(i = Cnt, t + 1, t)
        Cells(m, 1).Resize(w) = t
        Cells(m, 2).Resize(w) = t + n
        m = m + w
        If n + t = data Then n = 0: t = t + 1
    Next i
        For c = num * w To 1 Step -1
            If Int(data / 2) < Cells(c, 1) Then
                Cells(c, 1).Resize(, data - Int(data Mod 2)).Delete shift:=xlUp
            End If
        Next c
    If data > 4 Then
        Call 中村屋(ary, data, w)
    Else
        tbl = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 2).Value
        Cnt = 0
        For i = 1 To UBound(tbl, 1)
            dic(tbl(i, 1)) = Empty
            dic(tbl(i, 2)) = Empty
            t = 1
            For y = 1 To data - 2 - (data Mod 2)
                For p = t To UBound(ary)
                    If Not dic.exists(ary(p)) Then
                        Cells(i, y + 2) = ary(p)
                        dic(ary(p)) = Empty
                        t = p
                        If y = 1 Then
                            m = p
                        Else
                            v = p
                        End If
                        Exit For
                    End If
                Next p

            Next y
            u = IIf(i Mod 3 = 1, m, IIf(i Mod 3 = 2, v, IIf(i Mod 3 = 0, 5, 0)))
            If Cnt = 0 Then n = v
            Cnt = Cnt + 1

            If i Mod WorksheetFunction.Combin(data - 2, 2) = 0 Then
                dic.removeall

            ElseIf Cnt = 1 Then
                    dic.Remove (u)

            Else
                    dic.Remove (u)
                    dic.Remove (n)
            End If
        If Cnt = 3 Then Cnt = 0
    Next i
    For i = UBound(tbl, 1) To 1 Step -1
        If Cells(i, 3) < Int(data / 2) Then
            Cells(i, 1).Resize(, 4).Delete shift:=xlUp
        End If
    Next i
End If
    Application.ScreenUpdating = True
    Set dic = Nothing
End Sub
Sub 中村屋(ary, data, w)
    Dim n As Integer, f As Integer, mei As Integer, b As Integer
    Dim cnt_b As Integer
    If w >= 6 Then
        For y = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -6
            Cells(y, 1).Offset(-2).Resize(3, 2).Delete shift:=xlUp
        Next y
    End If
    tbl = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, data - Int(data Mod 2)).Value
    Cnt = 0
    If WorksheetFunction.Combin(data - 2, 2) >= 1 Then
        mei = Int(WorksheetFunction.Combin(data - 2, 2) / 2) + data Mod 2
        cnt_b = IIf(data - (data Mod 2) > 4, data - (data Mod 2), 3)
        For f = 3 To cnt_b Step 2
            b = b + 1
            For i = 1 To UBound(tbl, 1)
                For n = 1 To UBound(tbl, 2)
                    If Not IsEmpty(tbl(i, n)) Then
                        dic(tbl(i, n)) = Empty
                    End If
                Next n
                t = 1
                For y = 0 To 1
                    For p = t To UBound(ary)
                        If Not dic.exists(ary(p)) Then
                            Cells(i, f + y) = ary(p)
                            tbl(i, f + y) = ary(p)
                            t = p + 1
                            Exit For
                        End If
                    Next p
                Next y
                If f + 1 <> cnt_b Then
                    dic.removeall
                    For q = 1 To UBound(tbl, 2)
                        If Not IsEmpty(tbl(i, q)) Then
                            dic(tbl(i, q)) = Empty
                        End If
                    Next q
                    On Error Resume Next
                    Cnt = Cnt + 1
                    If Cnt Mod mei = 1 Then
                        If b = 1 Then
                            dic.Remove tbl(i, f)
                        Else
                            dic.Remove tbl(i, f + 1)
                        End If
                    ElseIf f = cnt_b Then
                        dic.Remove tbl(i, f + 1)
                        dic.Remove tbl(i - 1, f + 1)
                    ElseIf Cnt Mod mei = 2 Then
                        If b = 1 Then
                            If UBound(ary) < 6 Then
                                dic.Remove tbl(i, f + 1)
                                dic.Remove tbl(i - 1, f + 1)
                            Else
                                dic.Remove tbl(i, f)
                                dic(tbl(i - 1, f + 1)) = Empty
                            End If
                        Else
                            dic.Remove tbl(i, f)
                            dic.Remove tbl(i - 1, f)
                        End If
                    Else
                        dic.removeall
                    End If
                    If i Mod 3 = 0 Then
                        Cnt = 0: Cnt_c = 0: dic.removeall
                    End If
                End If
                If f + 1 = cnt_b Then dic.removeall
            Next i
            If f + 1 < cnt_b Then
                For x = UBound(tbl, 1) To 1 Step -1
                    If Cells(x, f) = 1 Then
                        Cells(x, 1).Resize(, f + 1).Delete shift:=xlUp
                    End If
                Next x
            End If
            tbl = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, _
                        Cells(1, 1).End(xlToRight).Column)
        Next f
    End If
    For i = UBound(tbl, 1) To 1 Step -1
        If Cells(i, 3) = "" Or Cells(i, 3) = 1 Then
            Cells(i, 1).Resize(, data - (data Mod 2)).Delete shift:=xlUp
        End If
    Next i
 End Sub

コメント返信：

[ 一覧(最新更新順) ]

[[20061225182121]] 『組み合わせ』（teni） ページの最後に飛ぶ

[[20061225182121]]　『組み合わせ』（teni）　ページの最後に飛ぶ