Results of 1 - 1 of about 7 for ダブルス (0.001 sec.)
- [[20140421134144]]
- #score: 11578
- @digest: f5eba10f396b6172bae6374e199a7740
- @id: 64985
- @mdate: 2014-04-30T03:10:51Z
- @size: 9714
- @type: text/plain
- #keywords: pair (102248), court (77592), numa (54223), sznum (51092), gamenum (41443), game (35475), counter (29803), numb (29564), hiroshi (21810), pn (19793), 選回 (12544), バド (12413), ・" (11642), mem (11083), 戦相 (8958), 抽選 (8301), sai (7196), テニ (6363), con (6309), ゲー (5943), ニス (5602), 対戦 (4562), 加者 (4420), 既出 (4041), resize (3621), 参加 (3522), cells (3430), 試合 (3376), randomize (2611), サク (2598), ペア (2558), application (2451)
- 追加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
... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201404/20140421134144.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97057 documents and 608292 words.
訪問者：