[[20070929173614]]　『組み合わせについて』（バド）　ページの最後に飛ぶ

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

　

『組み合わせについて』（バド） 
 バドミントンをやっていて、ダブルスの組み合わせに苦労するのですがエクセルで出来るのであれば教えてください。


 例
今日は10人の人が参加しての練習試合をしたとして
１回目はA・B　C・D・・・・・・とできますが
２回目以降が簡単に出来ません
参加人数により異なり少なければ簡単ですが大人数になると・・・
同じ人と組まないような式で如何なる（１０～４０人）人数にも対応できるような


 よろしくお願いいたします。
バドより


 全文検索で検索しましたか？例えば「ダブルス」で？
[[20070326234135]] 『テニスダブルスの組合せ』（TOM）
 （dack）
私の想像していたのとちょっと違うみたいです、バドミントン・テニスはダブルスで４人で１コートなのですが、
コート２面で８人の話ですが
１回目は当然Ａ・Ｂ対Ｃ・Ｄ　Ｅ・Ｆ対Ｇ・Ｈ
２回目は　　Ａ・Ｅ対Ｂ・Ｇ　Ｃ・Ｈ対Ｄ・Ｆ
10人であれば
２回目にＩとＪが加わりＧ・Ｈ・もしくはＡ・Ｂ抜けた標示がされる
という具合に参加人数に対しコート数を入力することによりデータが表示されるイメージだったのですみません。

（バド） 

 こんなコードを作ってみました。
 「　」で囲ってあるセルは見出しなので
 コードを実行する際には不必要です。
 A1「コート数」
 A2 コート数を入力
 A3「No.」
 A4以降「必要であれば通し番号」
 B1「試合数」
 B2 試合数を入力
 B3「参加者」
 B4以降　参加者名を入力


 E1以降2行を作業列に使っています。（最後に削除します。）
 C列に各個人が何回出場するか表示します。
 抽選を最大50回行い、どこかに重複があった場合
 重複を許して再抽選を行うか、処理を終了するか選べます。
 　たとえば、４組作る場合、4組のうちどれかの組が過去に組になっていたら
 　その抽選はなかったことにし、再度抽選を行う　という作業を
 　１試合につき50回まで繰り返します。
 重複を許して再抽選を行った結果には「★」がつきます。
 　対戦相手を決める際、以前に出てきたときとまったく同じ
 　組み合わせにならないよう注意してください。
 前回試合を行っていない人から優先で試合に参加するようになっていますので
 もしも、抽選がすべて行った際、C列にばらつきがある場合は
 再度抽選を行ってください。
（こちらで何度か試行した際　そのような状況があったので。
　原因がわからないので、放置してあります。気をつけてください。）


 エラー処理は行っていませんので
「コートが2面あるのに参加者が8人以下」のような場合は
 エラーがでます。
 人数、コート数等　確認して実行してください。


 抽選回数を「１試合につき50回まで」と区切っています。
 そのため、まだ重複しない組み合わせが残っていたとしても
 処理を中断します。
 抽選回数を増やせば、重複しない組み合わせが見つかる場合もあります。
（それまでの組み合わせによっては、変わらない場合もありますが。）
 回数を増やしたい場合は、コード内の2箇所に出てくる
 「counter = 50」の数字を変更してください。


 シートはこのような状態です。
 G4以降に結果が表示されます。
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]
[1]	コート数	試合数								
[2]	2	10								
[3]	NO.	参加者	出場回数							
[4]	1	A	8			1	B・I	A・H	C・E	F・J
[5]	2	B	8			2	A・G	D・E	B・H	F・I
[6]	3	C	8			3	D・G	E・I	B・J	C・H
[7]	4	D	8			4	C・D	B・F	E・G	A・J
[8]	5	E	8			5	C・J	A・F	G・I	D・H
[9]	6	F	8			6	B・E	A・C	F・G	H・J
[10]	7	G	8			7	G・J	C・I	E・F	B・D
[11]	8	H	8			8	D・J	C・G	A・I	F・H
[12]	9	I	8			9	B・G	I・J	A・D	E・H
[13]	10	J	8		★	10	F・I	D・E	A・B	C・H


 Sub NCM()
     Dim B_mr As Long
     Dim court As Long
     Dim pn As Long, tpn As Long
     Dim i 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
     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 - 3


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


     Cells(3, 3) = "出場回数"
     Cells(4, 3).Resize(pn) = 0


 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 + 3, 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) + 3, 3) = Cells(pair(1, i) + 3, 3) + 1
                 Cells(pair(2, i) + 3, 3) = Cells(pair(2, i) + 3, 3) + 1
                 Cells(k_game + 3, 6) = k_game
                 Cells(k_game + 3, i + 6) = Application.Index(Range("B4").Resize(pn), pair(1, i)) & "・" & Application.Index(Range("B4").Resize(pn), pair(2, i))
             Next
         C_min = Application.Small(Range("C4").Resize(pn), 1)  '←変更しました。
         If re_flg = 1 Then
             Cells(k_game + 3, 5) = "★"
         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 


 (HANA)
有難うございました。これで明日からチームが揉めないで楽しいバドミントンが出来ます。
本当に有難うございました。
（バド） 
 もう見て居られないかもしれませんが
 （しかも大した変更じゃない？）
 コードを少し変更しました。


 それに伴い、
 B4以降に参加者名を入力していましたが、
 B5以降に変更してください。


 参加者名の隣に、まだ組合せになっていない組が表示されます。
 また、結果は名前が入力された最終列の一つ下の行からの
 E列から表示します。
	[A]	[B]	[C]	[D]	[E]	[F]	[G]	[H]	[I]	[J]	[K]	[L]	[M]
[1]	コート数	試合数											
[2]	2	10											
[3]													
[4]	NO.	参加者	出場回数	A	B	C	D	E	F	G	H	I	J
[5]	1	A	8	*		A・C					A・H		
[6]	2	B	8		*	B・C	B・D						B・J
[7]	3	C	8	A・C	B・C	*					C・H		
[8]	4	D	8		B・D		*		D・F				
[9]	5	E	8					*		E・G			E・J
[10]	6	F	8				D・F		*		F・H	F・I	
[11]	7	G	8					E・G		*		G・I	
[12]	8	H	8	A・H		C・H			F・H		*		
[13]	9	I	8						F・I	G・I		*	
[14]	10	J	8		B・J			E・J					*
[15]													
[16]				1	B・H	I・J	A・F	C・D					
[17]				2	B・I	D・E	F・J	A・G					
[18]				3	F・G	A・B	D・H	C・E					
[19]				4	C・I	B・E	A・J	G・H					
[20]				5	C・F	D・G	H・J	E・I					
[21]				6	E・F	A・D	H・I	C・G					
[22]				7	D・I	B・G	A・E	C・J					
[23]				8	A・I	E・H	G・J	B・F					
[24]			★	9	E・H	F・J	B・I	C・D					
[25]			★	10	D・J	A・G	B・H	C・F					


 たとえば、「A・C , B・D , E・G , F・H」と言う４組は
 まだ作れますが、9試合目を選出中に試行が50回を超えたので
 9試合目以降は同じ組合せがでてきています。
 抽選が50回を超えた場合、処理を中止して
 この表を元に、後は手作業で対戦相手を見つけるのが良いかもしれません。


 以下がそのコードです。
 Sub NCM2()
     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


 なお、「50」と言う数字は　私が処理を待てる時間であって
 特に根拠のある数字ではありませんので、パソコンのスペックや
 使う人の忍耐に合わせて数字を変更してください。


 (HANA)

 最初の書き込みで
 ＞もしも、抽選がすべて行った際、C列にばらつきがある場合は
 ＞再度抽選を行ってください。
 なんて書きましたが、原因が分かったのでコードを修正しました。


 ・・・見てくださると良いのですが。


 (HANA)
ＨＡＮＡさん有難うございます。
試してみましたがＡが抜けるのですが何故でしょうかＢ、Ｃ、Ｄと標示されるのですが、Ｄ列にＡが表示されるはずなのにＢから標示されます。
（バド）
 3行目が１行あいて、4行目に見出し、
 5行目から名前が入ってますか？
 (HANA)
ＨＡＮＡさん有難うございました。
コメント返信：

[ 一覧(最新更新順) ]

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