Results of 1 - 1 of about 7 for ダブルス (0.001 sec.)
- [[20070929173614]]
- #score: 11578
- @digest: 1b076bbdf2b859cb631975b6f1e9f914
- @id: 33490
- @mdate: 2007-10-07T07:27:44Z
- @size: 12168
- @type: text/plain
- #keywords: pair (81798), court (77592), numa (54223), sznum (51092), gamenum (41443), game (35475), ・j (34579), 抽選 (33206), バド (33103), counter (32286), ・h (31508), numb (29564), ・i (27705), 選回 (25088), 度抽 (22246), 試合 (21948), 場回 (20363), ・g (19250), pn (17319), 選を (16217), 出場 (15582), ・f (13009), 加者 (10315), ・" (9314), ・e (9126), ・d (8969), ドミ (8537), 参加 (7748), 合数 (7576), ・c (3882), resize (3449), 回数 (3395)
- 『組み合わせについて』（バド）
バドミントンをやっていて、ダブルスの組み合わせに苦労するのですがエクセルで出来るのであれば教えてください。 例 今日は10人の人が参加しての練習試合をしたとして 1回目はA・B C・D・・・・・・とできますが 2回目以降が簡単に出来ません 参加人数により異なり少なければ簡単ですが大人数になると・・・ 同じ人と組まないような式で如何なる（10〜40人）人数にも対応できるような よろしくお願いいたします。 バドより ---- 全文検索で検索しましたか?例えば「ダブルス」で? [[20070326234135]] 『テニスダブルスの組合せ』（TOM） （dack） ---- 私の想像していたのとちょっと違うみたいです、バドミントン・テニスはダブルスで4人で1コートなのですが、 コート2面で8人の話ですが 1回目は当然A・B対C・D E・F対G・H 2回目は A・E対B・G C・H対D・F 10人であれば 2回目にIとJが加わりG・H・もしくはA・B抜けた標示がされる という具合に参加人数に対しコート数を入力することによりデータが表示されるイメージだったのですみません。 （バド） ---- こんなコードを作ってみました。 「 」で囲ってあるセルは見出しなので コードを実行する際には不必要です。 A1「コート数」 A2 コート数を入力 A3「No.」 A4以降「必要であれば通し番号」 B1「試合数」 B2 試合数を入力 B3「参加者」 B4以降 参加者名を入力 E1以降2行を作業列に使っています。（最後に削除します。） C列に各個人が何回出場するか表示します。 抽選を最大50回行い、どこかに重複があった場合 重複を許して再抽選を行うか、処理を終了するか選べます。 たとえば、4組作る場合、4組のうちどれかの組が過去に組になっていたら その抽選はなかったことにし、再度抽選を行う という作業を 1試合につき50回まで繰り返します。 重複を許して再抽選を行った結果には「★」がつきます。 対戦相手を決める際、以前に出てきたときとまったく同じ 組み合わせにならないよう注意してください。 前回試合を行っていない人から優先で試合に参加するようになっていますので もしも、抽選がすべて行った際、C列にばらつきがある場合は 再度抽選を行ってください。 （こちらで何度か試行した際 そのような状況があったので。 原因がわからないので、放置してあります。気をつけてください。） エラー処理は行っていませんので 「コートが2面あるのに参加者が8人以下」のような場合は エラーがでます。 人数、コート数等 確認して実行してください。 抽選回数を「1試合につき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("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 (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」と言う4組は まだ作れますが、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("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 なお、「50」と言う数字は 私が処理を待てる時間であって 特に根拠のある数字ではありませんので、パソコンのスペックや 使う人の忍耐に合わせて数字を変更してください。 (HANA) ---- 最初の書き込みで ＞もしも、抽選がすべて行った際、C列にばらつきがある場合は ＞再度抽選を行ってください。 なんて書きましたが、原因が分かったのでコードを修正しました。 ・・・見てくださると良いのですが。 (HANA) ---- HANAさん有難うございます。 試してみましたがAが抜けるのですが何故でしょうかB、C、Dと標示されるのですが、D列にAが表示されるはずなのにBから標示されます。 （バド） ---- 3行目が1行あいて、4行目に見出し、 5行目から名前が入ってますか? (HANA) ---- HANAさん有難うございました。... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/200709/20070929173614.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97057 documents and 608292 words.
訪問者：