[[20140421134144]] 『テニスのダブルスゲームの割り振り』(hiroshi) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

追加Qあり 『テニスのダブルスゲームの割り振り』(hiroshi)

テニスコート3面(ダブルス)で同時に12人ゲームをします。

参加者が13人〜20人程度で皆が均等にゲームに参加でき、対戦相手およびペアがなるべく被らない様な組合せを作るにはどうすれば宜しいでしょうか??

例えば13人の場合、最初は13番が休み、残りの12人で乱数で組合せは可能ですが、その後、12番休憩として、残りでなるべく対戦相手とペアが被らないようにしたい。

同様に14人、15人と20人程度まで参加者を増やしたケースを作りたいのですが。

< 使用 Excel:Excel2013、使用 OS:Windows7 >


 「ダブルス」で学校内を検索
http://www.excel.studio-kazu.jp/cgi-bin/estindex/estseek2.cgi?phrase=%E3%83%80%E3%83%96%E3%83%AB%E3%82%B9&perpage=10&attr=&order=@uri+STRD&clip=-1&navi=0
 
(GobGob) 2014/04/21(月) 14:09

既出でしたか・・・

申し訳ありません。いまから確認して、解らなければ再度アップします。
(hiroshi) 2014/04/21(月) 14:20


追Qをお願いします。

既出マクロでコート割ができました。有難うございます。
で、追加質問なんですが、コートに入らない(ゲームをしない)番号も一目でわかるように出来ないでしょうか?

人数が多くなると、コートに入らない人を探すのが難しくなります。

度々厚かましいお願いですが、宜しくお願いいたします。
(hiroshi) 2014/04/24(木) 09:36


 >既出マクロ

 いつ、誰が作成したものか分からないと始まらないような気がしますけど?

(半平太) 2014/04/24(木) 17:45


失礼しました。
最初に紹介があった以下のマクロを使用しました。

Sub バド()
Dim B_mr As Long

     Dim court As Long
     Dim pn As Long, tpn As Long
     Dim i As Long, ii As Long, C_min As Long, sznum As Long, numA As Long, numB As Long
     Dim gamenum As Long, k_game As Long, counter As Long
     Dim no_flg As Long, re_flg As Long, sai As Long
     Dim pair As Variant, con As Variant
     Dim dic As Object

 Randomize
 Set dic = CreateObject("Scripting.Dictionary")
 court = Range("A2").Value
 gamenum = Range("B2").Value
 B_mr = Cells(Rows.Count, 2).End(xlUp).Row
 tpn = court * 4
 pn = B_mr - 4

     ReDim pair(1 To 2, 1 To court * 2)
     ReDim con(1 To pn, 1 To pn)
     Range("C1").Resize(Rows.Count, Columns.Count - 2).Clear

     For i = 1 To pn
     For ii = 1 To pn
         If i = ii Then
         con(i, ii) = "*"
         Else
         con(i, ii) = IIf(i < ii, Cells(i + 4, 2) & "・" & Cells(ii + 4, 2), Cells(ii + 4, 2) & "・" & Cells(i + 4, 2))
         End If
     Next
     Next

     Cells(4, 3) = "出場回数"
     Cells(5, 3).Resize(pn) = 0
     Cells(4, 4).Resize(, pn) = Application.Transpose(Cells(5, 2).Resize(pn))
     Cells(5, 4).Resize(pn, pn) = con
 Do

     For i = 1 To pn
         Cells(1, i + 4) = Rnd
         Cells(2, i + 4) = Empty
     Next

     sznum = 0
     For i = 1 To pn
         If Cells(i + 4, 3) = C_min Then
             sznum = sznum + 1
             Cells(2, i + 4) = Cells(1, i + 4)
             Cells(1, i + 4) = Empty
         End If
     Next

     If sznum < tpn Then
         For i = 1 To tpn - sznum
             numA = Application.Match(Application.Small(Range("E1").Resize(, pn), i), Range("E1").Resize(, pn), 0)
             Cells(2, numA + 4) = Cells(1, numA + 4)
         Next
     End If

     For i = 1 To court * 2
         numA = Application.Match(Application.Small(Range("E2").Resize(, pn), i), Range("E2").Resize(, pn), 0)
         numB = Application.Match(Application.Small(Range("E2").Resize(, pn), i + court * 2), Range("E2").Resize(, pn), 0)

         pair(1, i) = IIf(numA < numB, numA, numB)
         pair(2, i) = IIf(numA < numB, numB, numA)
     Next

     no_flg = 0
     For i = 1 To court * 2
         If dic.exists(pair(1, i) & "・" & pair(2, i)) Then
             no_flg = 1
             i = court * 2
         End If
     Next

     If no_flg = 0 Then
         k_game = k_game + 1
             For i = 1 To court * 2
                 dic(pair(1, i) & "・" & pair(2, i)) = ""
                 Cells(pair(1, i) + 4, 3) = Cells(pair(1, i) + 4, 3) + 1
                 Cells(pair(2, i) + 4, 3) = Cells(pair(2, i) + 4, 3) + 1
                 Cells(k_game + B_mr + 1, 4) = k_game
                 Cells(k_game + B_mr + 1, i + 4) = Application.Index(Range("B5").Resize(pn), pair(1, i)) & "・" & Application.Index(Range("B5").Resize(pn), pair(2, i))
                 Cells(pair(1, i) + 4, pair(2, i) + 3) = Empty
                 Cells(pair(2, i) + 4, pair(1, i) + 3) = Empty
             Next
         C_min = Application.Small(Range("C5").Resize(pn), 1) '←変更しました
         If re_flg = 1 Then
             Cells(k_game + B_mr + 1, 3) = "★"
         End If
     Else
         counter = counter + 1

         If counter = 50 Then
             sai = MsgBox("1試合の抽選回数が50回を超えました。" & Chr(13) & "重複を許して、再度抽選を行いますか?", vbYesNo)
         End If

         If sai = 6 Then
             dic.RemoveAll
             counter = 0
             re_flg = 1
         End If
     End If

 Loop Until k_game = gamenum Or counter = 50

     Range("E1").CurrentRegion.Clear

End Sub

(hiroshi) 2014/04/28(月) 11:40


 ↓ですね。
[[20070929173614]] 『組み合わせについて』(バド)

 コード変更しましたので、以下でやってみてもらえますか?

 '------
Sub バド2()
     Dim B_mr As Long
     Dim court As Long
     Dim pn As Long, tpn As Long
     Dim i As Long, ii As Long, C_min As Long, sznum As Long, numA As Long, numB As Long
     Dim gamenum As Long, k_game As Long, counter As Long
     Dim no_flg As Long, re_flg As Long, sai As Long
     Dim pair As Variant, con As Variant
     Dim dic As Object
     Dim mem As Variant

 Randomize
 Set dic = CreateObject("Scripting.Dictionary")
 court = Range("A2").Value
 gamenum = Range("B2").Value
 B_mr = Cells(Rows.Count, 2).End(xlUp).Row
 tpn = court * 4
 pn = B_mr - 4

     ReDim pair(1 To 2, 1 To court * 2)
     ReDim con(1 To pn, 1 To pn)
     Range("C1").Resize(Rows.Count, Columns.Count - 2).ClearContents

     For i = 1 To pn
     For ii = 1 To pn
         If i = ii Then
         con(i, ii) = "*"
         Else
         con(i, ii) = IIf(i < ii, Cells(i + 4, 2) & "・" & Cells(ii + 4, 2), Cells(ii + 4, 2) & "・" & Cells(i + 4, 2))
         End If
     Next
     Next

     Cells(4, 3) = "出場回数"
     Cells(5, 3).Resize(pn) = 0
     Cells(4, 4).Resize(, pn) = Application.Transpose(Cells(5, 2).Resize(pn))
     Cells(5, 4).Resize(pn, pn) = con
 Do
     For i = 1 To pn
         Cells(1, i + 4) = Rnd
         Cells(2, i + 4) = Empty
     Next

     sznum = 0
     For i = 1 To pn
         If Cells(i + 4, 3) = C_min Then
             sznum = sznum + 1
             Cells(2, i + 4) = Cells(1, i + 4)
             Cells(1, i + 4) = Empty
         End If
     Next

     If sznum < tpn Then
         For i = 1 To tpn - sznum
             numA = Application.Match(Application.Small(Range("E1").Resize(, pn), i), Range("E1").Resize(, pn), 0)
             Cells(2, numA + 4) = Cells(1, numA + 4)
         Next
     End If

     For i = 1 To court * 2
         numA = Application.Match(Application.Small(Range("E2").Resize(, pn), i), Range("E2").Resize(, pn), 0)
         numB = Application.Match(Application.Small(Range("E2").Resize(, pn), i + court * 2), Range("E2").Resize(, pn), 0)

         pair(1, i) = IIf(numA < numB, numA, numB)
         pair(2, i) = IIf(numA < numB, numB, numA)
     Next

     no_flg = 0
     For i = 1 To court * 2
         If dic.exists(pair(1, i) & "・" & pair(2, i)) Then
             no_flg = 1
             i = court * 2
         End If
     Next

     If no_flg = 0 Then
         mem = Range("B5").Resize(pn, 1).Value
         k_game = k_game + 1
             For i = 1 To court * 2
                 dic(pair(1, i) & "・" & pair(2, i)) = ""
                 Cells(pair(1, i) + 4, 3) = Cells(pair(1, i) + 4, 3) + 1
                 Cells(pair(2, i) + 4, 3) = Cells(pair(2, i) + 4, 3) + 1
                 Cells(k_game + B_mr + 1, 4) = k_game
                 Cells(k_game + B_mr + 1, i + 4) = mem(pair(1, i), 1) & "・" & mem(pair(2, i), 1)
                 mem(pair(1, i), 1) = Application.Rept(" ", LenB(StrConv(mem(pair(1, i), 1), vbFromUnicode)))
                 mem(pair(2, i), 1) = Application.Rept(" ", LenB(StrConv(mem(pair(2, i), 1), vbFromUnicode)))
                 Cells(pair(1, i) + 4, pair(2, i) + 3) = Empty
                 Cells(pair(2, i) + 4, pair(1, i) + 3) = Empty
             Next
         C_min = Application.Small(Range("C5").Resize(pn), 1)
         If re_flg = 1 Then
             Cells(k_game + B_mr + 1, 3) = "★"
         End If
         Cells(k_game + B_mr + 1, i + 4) = Join(Application.Transpose(mem), "・")
     Else
         counter = counter + 1

         If counter = 50 Then
             sai = MsgBox("1試合の抽選回数が50回を超えました。" & Chr(13) & "重複を許して、再度抽選を行いますか?", vbYesNo)
         End If

         If sai = 6 Then
             dic.RemoveAll
             counter = 0
             re_flg = 1
         End If
     End If

 Loop Until k_game = gamenum Or counter = 50

     Range("E1").CurrentRegion.ClearContents
End Sub
 '------

 組み合わせ表の後ろに、その他のメンバーの名前を出しています。
 コートに入った人の部分は同じ文字数スペースを入れているので
 等幅フォントにして確認してもらえると良いかもしれません。

 参加人数が多い場合や参加者名が長い場合は、スペースはない方が良いのかもしれませんが。。。
  
(HANA) 2014/04/29(火) 00:29
         2014/04/29(火) 01:35 コード少し変更しました。

HANAさま

有難うございます。
これでサクサクとゲームを進めることができます。

(hiroshi) 2014/04/30(水) 12:10


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.