[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
追加Ｑあり 『テニスのダブルスゲームの割り振り』（hiroshi）
テニスコート３面（ダブルス）で同時に１２人ゲームをします。
参加者が１３人〜２０人程度で皆が均等にゲームに参加でき、対戦相手およびペアがなるべく被らない様な組合せを作るにはどうすれば宜しいでしょうか？？
例えば１３人の場合、最初は１３番が休み、残りの１２人で乱数で組合せは可能ですが、その後、１２番休憩として、残りでなるべく対戦相手とペアが被らないようにしたい。
同様に１４人、１５人と２０人程度まで参加者を増やしたケースを作りたいのですが。
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
「ダブルス」で学校内を検索 https://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("１試合の抽選回数が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("１試合の抽選回数が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.