[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
追加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
既出マクロでコート割ができました。有難うございます。
で、追加質問なんですが、コートに入らない(ゲームをしない)番号も一目でわかるように出来ないでしょうか?
人数が多くなると、コートに入らない人を探すのが難しくなります。
度々厚かましいお願いですが、宜しくお願いいたします。
(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 コード少し変更しました。
有難うございます。
これでサクサクとゲームを進めることができます。
(hiroshi) 2014/04/30(水) 12:10
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.