『テニスダブルスの組合せ』（ＴＯＭ） すいません。もしかしたらこちらに質問するのはおかしい内容なのかも知れませんが、なかなか一人では結論がでず、助けを求めにきました。 内容は テニスのダブルスの組合せで、毎回参加人数が違うのですが最後に、みんなで、試合をします。参加者全員が、満遍なく対戦し、毎回ダブルスを組ペアも違うよいうに組合せを考えたいのですが、エクセルでは計算できませんかね?? 例えば、Ａ1に4（人）と入れると組合せが計算できるような・・・ 　　　Ａ　　　　　Ｂ　　　　　　Ｃ　　　　　　　Ｄ 1　　４人　　1・2/3/4　　1・3/2・4　　1・4/2・3 ４人の場合はこの３つの組合せだと思うのですが、これが５人６人と増えた場合の組合せを計算するには、時間をかけてコツコツ組合せをはじき出すしかありませんか？ １０人くらいまでの組合せが出来ればいいのですが、宜しくお願いします。 ---- エクセルは初級者（初心者！？）ですが、テニス好きとしての意見です。 全くの回答になっていませんが・・・(汗) １０人となるとペア組みだけで４５組できます。それを満遍なく対戦させる！？ なんてことは時間上可能でしょうか？コートを何面押さえられて、何時間 取られているのかもわかりませんが・・・。 また、ペア１・２をどのペアと対戦させるか？ ３・４なのか４・５なのか、 それとも９・１０なのか・・・。この辺はどうお考えですか？全部となると それこそとてつもない試合数になってしまいます。。。 個人的には、一人づつづらしてしくのが良いと考えます。 直前の対戦相手の一人とペアを組むようにするとか・・・ （例）　８人の場合 １・２／３・４、５・６／７・８、１・３／５・７、２・４、６・８ １・５／２・６、３・７／４・８、・・・ かといって、この式も私には作れません。。。ごめんなさい。 （ぎょたく） ---- 回答じゃありませんが、すべての組み合わせ試合数は、 =COMBIN(A1,4)*3 で出ると思います。(A1が人数) 　 よって10人だと 630試合必要なことになりますね。 （純丸）(o^-')b ---- 回答やおまへんけど 例えば参加者６人のやったばやいの事を考えてみまひょか 1.2がペアを組んだばやい、ぎょたくはんの論理からすれば　常に対戦相手は3.4と 5.6になりますわなぁ。 つまり、3.5の最強コンビと一戦を交える事はありまへんし、4.6の美人ペアとも楽しむ 事はありまへんわなぁ。 1.2がペアを組んだ対戦相手は3.4 5.6 　3.5 4.6 　3.6 4.5が存在しなければならん 筈ですからこれをどう取り扱うかが問題になります。 勿論1.3　がペアを組んでも、1.4がペアを組んでもそれぞれ対戦相手が3通りずつ有る 事になります。 方法の一つとして、全ての組合せを拾い出して、1.2の組合せをrnd関数で一組を抽出 し、その組合せが重複しない1.3 1.4 1.5 1.6の組合せをマクロで検索抽出の方法しか ないんとちゃいまっしゃろか？ そこまで考えたマクロやおまへんけど、正月に似たようなスレがありましたんで、 載せときますワ。役に立つかどうかはわかりまへんけど・・・・ InputBoxに参加人員を記入するとその組合せが抽出されます。 但し８人以上は組合わせ数が多いんで、全てを表記するようにはなっとりまへん。 勿論３０人でも４０人でもOKです。 　　　　　（弥太郎） '--------------- Dim c_data As Integer Dim patrndata As String, a_data As Integer, b_data As Integer Sub テニス組合せ() Dim dic As Object, i As Long, t As Long, data_over As Integer, tbl, x, w, s Dim Rex As Object, c As Integer, r As Integer, n As Integer, ary Set Rex = CreateObject("vbscript.regexp") Set dic = CreateObject("scripting.dictionary") data = Val(StrConv(InputBox("何人で遊びまっか？"), vbNarrow)) If data > 8 Then data_over = Val(StrConv(InputBox("何組ひろいまひょ？"), vbNarrow)) End If e_data (data) ReDim ary(1 To data) For i = 1 To data ary(i) = i Next i If data_over > 0 Then Call over_size(data, ary, data_over): Exit Sub Select Case data Case 4 Cells(1, 1).Resize(, 4) = Array(1, 2, 3, 4) Cells(2, 1).Resize(, 4) = Array(1, 3, 2, 4) Cells(3, 1).Resize(, 4) = Array(1, 4, 2, 3) Exit Sub Case 5 Cells(1, 1).Resize(15) = Application.Transpose(Array(1, 1, 1, 1, 1, 1, _ 1, 1, 1, 1, 1, 1, 2, 2, 2)) Cells(1, 2).Resize(15) = Application.Transpose(Array(2, 2, 2, 3, 3, 3, 4, _ 4, 4, 5, 5, 5, 3, 4, 5)) Cells(1, 3).Resize(15) = Application.Transpose(Array(3, 3, 4, 2, 2, 4, _ 2, 2, 3, 2, 2, 3, 4, 3, 3)) Cells(1, 4).Resize(15) = Application.Transpose(Array(4, 5, 5, 4, 5, 5, _ 3, 5, 5, 3, 4, 4, 5, 5, 4)) Exit Sub Case 6 Cells(1, 1).Resize(15) = 1 Cells(1, 2).Resize(15) = Application.Transpose(Array(2, 2, 2, 3, 3, 3, _ 4, 4, 4, 5, 5, 5, 6, 6, 6)) Cells(1, 3).Resize(15) = Application.Transpose(Array(3, 3, 3, 2, 2, 2, _ 2, 2, 2, 2, 2, 2, 2, 2, 2)) Cells(1, 4).Resize(15) = Application.Transpose(Array(4, 5, 6, 4, 5, 6, _ 3, 5, 6, 3, 4, 6, 3, 4, 5)) Cells(1, 5).Resize(15) = Application.Transpose(Array(5, 4, 4, 5, 4, 4, _ 5, 3, 3, 4, 3, 3, 4, 3, 3)) Cells(1, 6).Resize(15) = Application.Transpose(Array(6, 6, 5, 6, 6, 5, _ 6, 6, 5, 6, 6, 4, 5, 5, 4)) Exit Sub Case 7, 8 tbl = Cells(1, 1).Resize(b_data, data) ReDim x(1 To UBound(tbl, 1), 1 To UBound(tbl, 2)) ReDim s(1 To Int(UBound(tbl, 2) / 2)) ReDim mein(1 To UBound(tbl, 2) / 2 - 1) For n = 1 To UBound(tbl, 2) Step 2 t = 1: f = 1 If n = 1 Then For i = 1 To UBound(tbl, 1) If UBound(tbl, 2) Mod 2 = 0 Then tbl(i, n) = ary(n) tbl(i, n + 1) = ary(n + t) If i Mod a_data = 0 Then t = t + 1 End If Else If i <= b_data - a_data Then tbl(i, n) = ary(n) tbl(i, n + 1) = ary(n + t) If i Mod a_data = 0 Then t = t + 1 End If Else tbl(i, n) = ary(n + 1) tbl(i, n + 1) = ary(n + 1 + f) If i Mod c_data = 0 Then f = f + 1 End If End If End If Next i ElseIf n = 3 Then If data = 8 Then For i = 1 To UBound(tbl, 1) If i <= a_data Then tbl(i, n) = 3 Else tbl(i, n) = 2 End If Next i For i = 1 To UBound(tbl, 1) r = 1 dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, 4) = ary(s) r = s + 1 If i Mod c_data = 0 Then dic(ary(s)) = Empty End If Exit For End If Next s If i Mod a_data = 0 Then dic.removeall Next i For i = 1 To UBound(tbl, 1) r = 1 dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty dic(tbl(i, 4)) = Empty For j = 5 To 6 For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, j) = ary(s) Cells(i, j) = ary(s) r = s + 1 If j = 6 Then dic(tbl(i, j)) = Empty Exit For End If Next s Next j If i Mod c_data = 0 Then dic.removeall Next i For i = 1 To UBound(tbl, 1) r = 1 dic.removeall For j = 1 To UBound(tbl, 2) - 2 dic(tbl(i, j)) = Empty Next j For j = 7 To 8 For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, j) = ary(s) r = s + 1 Exit For End If Next s Next j Next i Else t = 0 Cnt = 1 For i = 1 To UBound(tbl, 1) If UBound(tbl, 2) Mod 2 = 0 Then tbl(i, n) = ary(n + t) If i = a_data Then t = -1 Else If (i Mod a_data = 13 Or i Mod a_data = 0 Or i Mod a_data = 14) _ And i <= b_data - a_data Then Select Case tbl(i, n - 1) Case 2, 3 tbl(i, n) = 4 Case Else tbl(i, n) = 3 End Select ElseIf i > b_data - a_data Then tbl(i, n) = IIf(tbl(i, n - 1) = 3, 4, 3) Else tbl(i, n) = IIf(tbl(i, n - 1) = 2, 3, 2) End If End If Next i If data = 7 Then c = 1 For i = 1 To UBound(tbl, 1) dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty For s = 1 To UBound(ary) If Not dic.exists(ary(s)) And tbl(i, 3) < ary(s) Then tbl(i, 4) = ary(s) If i > a_data * (data - 1) Then dic(tbl(i, 4)) = Empty Exit For End If If i Mod c_data = 0 Or i Mod a_data = 13 Or i Mod a_data = 14 Then dic(tbl(i, 4)) = Empty End If Exit For End If Next s If i Mod ((a_data * c) - c_data) = 0 Or i Mod a_data = 0 Then c = IIf(i Mod ((a_data * c) - c_data) = 0, c + 1, c) dic.removeall End If If i > a_data * (data - 1) And i Mod c_data = 0 Then dic.removeall End If If i = a_data * (data - 1) Then For j = 1 To data - 1 ary(j) = ary(j + 1) Next j End If Next i For j = 1 To data ary(j) = j Next j c = 1 For i = 1 To UBound(tbl, 1) dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty dic(tbl(i, 4)) = Empty r = 1 For j = 5 To 6 For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, j) = ary(s) r = s + 1 Exit For End If Next s Next j dic.removeall If i < a_data * (data - 1) Then If i Mod a_data = 0 Or i Mod ((a_data * c) - c_data) = 0 Or i _ Mod a_data = 13 Or i Mod a_data = 14 Then dic(tbl(i - 3, 3)) = Empty c = IIf(i Mod ((a_data * c) - c_data) = 0, c + 1, c) Else Select Case i Mod c_data Case 1 dic(tbl(i, 6)) = Empty Case 2 dic(tbl(i, 5)) = Empty Case Else dic.removeall End Select End If End If If i = a_data * (data - 1) Then For j = 1 To data - 1 ary(j) = ary(j + 1) Next j End If Next i End If End If End If Next n End Select Cells(1, 1).Resize(UBound(tbl, 1), UBound(tbl, 2) - Int(data Mod 2)) = tbl Set dic = Nothing End Sub Sub e_data(data) Select Case data Case 7 a_data = 15 b_data = 105 c_data = 3 Case 8 a_data = 15 b_data = 105 c_data = 3 End Select End Sub Sub over_size(data, ary, data_over) 'Randomize Dim dic As Object, dic1 As Object, j As Integer, i As Integer, b As Integer Dim n As Integer, m As Integer, t, x, tbl, tbl1, s Dim mei As String, col As Integer Set dic1 = CreateObject("scripting.dictionary") Set dic = CreateObject("scripting.dictionary") ReDim tbl(1 To 1, 1 To data - data Mod 2) ReDim tbl1(1 To data_over, 1 To data - data Mod 2) For j = 1 To UBound(tbl1, 1) i = 0 Do While i < data - 1 Randomize i = i + 1 tbl(1, i) = Int(Rnd * data) + 1 If dic.exists(tbl(1, i)) Then i = i - 1 Else dic(tbl(1, i)) = Empty End If Loop If data Mod 2 = 0 Then tbl(1, data) = WorksheetFunction.Sum(ary) - WorksheetFunction.Sum(tbl) For n = 1 To data - data Mod 2 Step 2 If tbl(1, n) > tbl(1, n + 1) Then tensya = tbl(1, n) tbl(1, n) = tbl(1, n + 1) tbl(1, n + 1) = tensya End If Next n ReDim x(1 To Int(data / 2)) m = 0 For i = 1 To data - data Mod 2 Step 2 m = m + 1 x(m) = tbl(1, i) Next i b = 1 For i = 1 To Int(data / 2) tbl1(j, b) = WorksheetFunction.Small(x, i) t = WorksheetFunction.Match(tbl1(j, b), x, 0) tbl1(j, b + 1) = tbl(1, WorksheetFunction.Match(WorksheetFunction.Small(x, i), x, 0) * 2) b = b + 2 Next i Cells(1, 1).Resize(, data - data Mod 2) = tbl1 ReDim s(1 To Int(data / 2)) m = 0 For col = 1 To data - data Mod 2 Step 2 m = m + 1 s(m) = tbl1(j, col) & "-" & tbl1(j, col + 1) Next col mei = Join(s, ",") If Not dic1.exists(mei) Then dic1(mei) = Empty Else i = i - 1 End If dic.removeall tbl(1, UBound(tbl, 2)) = Empty Next j Cells(1, 1).Resize(UBound(tbl1, 1), UBound(tbl1, 2)) = tbl1 Set dic = Nothing End Sub ---- （ぎょたく）さん（純丸）さん（弥太郎）さん 有難うございます。 もう少し対戦のルールなどを考えてペアの組み方を考えて見ます。 純丸さん・弥太郎さんがかいてあるとおり、現状は、ひとりづつずらしながらやっていますが、結局近い番号の人としか組まなかったり、対戦しなかったりしています。 人数が多いとたしかに組み合わせが膨大でぎょたくさんのご指摘どおり何時間あっても終わらないですね。。。人数が多数の時はペアは固定するとか工夫します。 的はずれな質問にお答えいただき有難うございます。 また、弥太郎さんからの以前の数式？！私の知識だとまったく手が出ません。もし時間がありましたら、ご教授願います。（マクロはまったく知識がありません。。。） ＴＯＭ ---- 弥太郎さん、こんにちは！ >1.2がペアを組んだばやい、ぎょたくはんの論理からすれば　常に対戦相手は3.4と >5.6になりますわなぁ。 >つまり、3.5の最強コンビと一戦を交える事はありまへんし、4.6の美人ペアとも楽し む >事はありまへんわなぁ。 そういうつもりではなかったのですが、書き方が悪かったですね。 反省。。。 3.5の最強コンビとも、4.6の美人ペアとも是非とも対戦したいです^^ 私もマクロは超ド素人なので上記式について教えて頂きたいのですが・・・。 ページタブ右クリック→コードの表示にコード貼り付け の後はどのようにしたら良いのでしょうか？ >InputBoxに参加人員を記入するとその組合せが抽出されます。 すみません。InputBoxがわかりません。 (ぎょたく) ---- ぎょたくは〜ん、こんばんは〜。 いや、仕事で遅うなってごめんなはれや。 これはAlt+F11でVBEを開きまんねん。 それで「挿入」→「標準モジュール」を選択し その真新しい画面に上のコードをコピペするっちゅうだけの作業なんですわ（笑 でもって、その作業が終了したら右上の×印をクリックしてエクセルに戻り、 今度はAlt+F8若しくは▲が右を向いた（チップテキストでマクロの実行と表示される） コマンドをクリックして、テニス組合せを実行してみてくらはい。 さすればInputoBoxなるものが表示されますから、そこへ数字を書き込めばそれがしの 説明したデータが表示されるようになっとります。 時間があればそのうちの一つを選択するとそれに重複しない組合せを表示するマクロに 取り組んでもよろしいんやけど、なんせ、忙しゅうて・・・・（笑 　　　　（弥太郎） ---- 関数なら　　組合せる数の内4個抽出で　　 C1=1　D1=2　E1=3　F1=4 C2= IF(AND(C1+3=$H$1,F1=$H$1),B2+1,IF(C1=$H$1-3,B1+2,IF(D1=$H$1-2,C1+1,C1))) D2= IF(AND(D1+2=$H$1,F1=$H$1),C2+1,IF(D1=$H$1-2,C1+2,IF(E1=$H$1-1,D1+1,D1))) E2= IF(AND(E1+1=$H$1,F1=$H$1),D2+1,IF(E1=$H$1-1,D1+2,IF(F1=$H$1,E1+1,E1))) F2= IF(E1=$H$1-1,E2+1,IF(F1=$H$1,E1+2,F1+1)) H1= 組合せる数入力 H2= COMBIN(H1,4)　　　　組合せ総数 COMBIN(15,4)で1365行必要 条件書式で　数式が　=COMBIN(H1,4) 10 Then data_over = Val(StrConv(InputBox("何組ほど拾いまひょ？"), vbNarrow)) Call over_size(data, ary, data_over): Exit Sub ElseIf data > 6 Then If vbYes = MsgBox("ランダムに拾い出しまっか？", vbYesNo) Then data_over = Val(StrConv(InputBox("何組ほど拾いまひょ？"), vbNarrow)) Call over_size(data, ary, data_over): Exit Sub End If End If With Sheets("sheet1") .Cells.ClearContents Select Case data Case 4 .Cells(1, 1).Resize(, 2) = Array("1,2", "3,4") .Cells(2, 1).Resize(, 2) = Array("1,3", "2,4") .Cells(3, 1).Resize(, 2) = Array("1,4", "2,3") Exit Sub Case 5 .Cells(1, 1).Resize(15) = Application.Transpose(Array("1,2", "1,2", "1,2", _ "1,3", "1,3", "1,3", "1,4", "1,4", "1,4", "1,5", "1,5", "1,5", _ "2,3", "2,4", "2,5")) .Cells(1, 2).Resize(15) = Application.Transpose(Array("3,4", "3,5", "4,5", "2,4", "2,5", _ "4,5", "2,3", "2,5", "3,5", "2,3", "2,4", "3,4", _ "4,5", "3,5", "3,4")) Exit Sub Case 6 .Cells(1, 1).Resize(15) = Application.Transpose(Array("1,2", "1,2", "1,2", _ "1,3", "1,3", "1,3", "1,4", "1,4", "1,4", "1,5", "1,5", "1,5", _ "1,6", "1,6", "1,6")) .Cells(1, 2).Resize(15) = Application.Transpose(Array("3,4", "3,5", "3,6", _ "2,4", "2,5", "2,6", "2,3", "2,5", "2,6", "2,3", "2,4", "2,6", _ "2,3", "2,4", "2,5")) .Cells(1, 3).Resize(15) = Application.Transpose(Array("5,6", "4,6", "4,5", _ "5,6", "4,6", "4,5", "5,6", "3,6", "3,5", "4,6", "3,6", "3,4", _ "4,5", "3,5", "3,4")) Exit Sub Case 7, 8 tbl = .Cells(1, 1).Resize(b_data, data) For n = 1 To UBound(tbl, 2) Step 2 t = 1: f = 1 If n = 1 Then For i = 1 To UBound(tbl, 1) If UBound(tbl, 2) Mod 2 = 0 Then tbl(i, n) = ary(n) tbl(i, n + 1) = ary(n + t) If i Mod a_data = 0 Then t = t + 1 End If Else If i <= b_data - a_data Then tbl(i, n) = ary(n) tbl(i, n + 1) = ary(n + t) If i Mod a_data = 0 Then t = t + 1 End If Else tbl(i, n) = ary(n + 1) tbl(i, n + 1) = ary(n + 1 + f) If i Mod c_data = 0 Then f = f + 1 End If End If End If Next i ElseIf n = 3 Then If data = 8 Then For i = 1 To UBound(tbl, 1) If i <= a_data Then tbl(i, n) = 3 Else tbl(i, n) = 2 End If Next i For i = 1 To UBound(tbl, 1) r = 1 dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, 4) = ary(s) r = s + 1 If i Mod c_data = 0 Then dic(ary(s)) = Empty End If Exit For End If Next s If i Mod a_data = 0 Then dic.removeall Next i For i = 1 To UBound(tbl, 1) r = 1 dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty dic(tbl(i, 4)) = Empty For j = 5 To 6 For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, j) = ary(s) r = s + 1 If j = 6 Then dic(tbl(i, j)) = Empty Exit For End If Next s Next j If i Mod c_data = 0 Then dic.removeall Next i For i = 1 To UBound(tbl, 1) r = 1 dic.removeall For j = 1 To UBound(tbl, 2) - 2 dic(tbl(i, j)) = Empty Next j For j = 7 To 8 For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, j) = ary(s) r = s + 1 Exit For End If Next s Next j Next i Else t = 0 Cnt = 1 For i = 1 To UBound(tbl, 1) If UBound(tbl, 2) Mod 2 = 0 Then tbl(i, n) = ary(n + t) If i = a_data Then t = -1 Else If (i Mod a_data = 13 Or i Mod a_data = 0 Or i Mod a_data = 14) _ And i <= b_data - a_data Then Select Case tbl(i, n - 1) Case 2, 3 tbl(i, n) = 4 Case Else tbl(i, n) = 3 End Select ElseIf i > b_data - a_data Then tbl(i, n) = IIf(tbl(i, n - 1) = 3, 4, 3) Else tbl(i, n) = IIf(tbl(i, n - 1) = 2, 3, 2) End If End If Next i If data = 7 Then c = 1 For i = 1 To UBound(tbl, 1) dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty For s = 1 To UBound(ary) If Not dic.exists(ary(s)) And tbl(i, 3) < ary(s) Then tbl(i, 4) = ary(s) If i > a_data * (data - 1) Then dic(tbl(i, 4)) = Empty Exit For End If If i Mod c_data = 0 Or i Mod a_data = 13 Or i Mod a_data = 14 Then dic(tbl(i, 4)) = Empty End If Exit For End If Next s If i Mod ((a_data * c) - c_data) = 0 Or i Mod a_data = 0 Then c = IIf(i Mod ((a_data * c) - c_data) = 0, c + 1, c) dic.removeall End If If i > a_data * (data - 1) And i Mod c_data = 0 Then dic.removeall End If If i = a_data * (data - 1) Then For j = 1 To data - 1 ary(j) = ary(j + 1) Next j End If Next i For j = 1 To data ary(j) = j Next j c = 1 For i = 1 To UBound(tbl, 1) dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty dic(tbl(i, 4)) = Empty r = 1 For j = 5 To 6 For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, j) = ary(s) r = s + 1 Exit For End If Next s Next j dic.removeall If i < a_data * (data - 1) Then If i Mod a_data = 0 Or i Mod ((a_data * c) - c_data) = 0 Or i _ Mod a_data = 13 Or i Mod a_data = 14 Then dic(tbl(i - 3, 3)) = Empty c = IIf(i Mod ((a_data * c) - c_data) = 0, c + 1, c) Else Select Case i Mod c_data Case 1 dic(tbl(i, 6)) = Empty Case 2 dic(tbl(i, 5)) = Empty Case Else dic.removeall End Select End If End If If i = a_data * (data - 1) Then For j = 1 To data - 1 ary(j) = ary(j + 1) Next j End If Next i End If End If End If Next n Case 9, 10 tbl = .Cells(1, 1).Resize(b_data, data) For n = 1 To UBound(tbl, 2) Step 2 t = 1: f = 1 If n = 1 Then For i = 1 To UBound(tbl, 1) If UBound(tbl, 2) Mod 2 = 0 Then tbl(i, n) = ary(n) tbl(i, n + 1) = ary(n + t) If i Mod a_data = 0 Then t = t + 1 End If Else If i <= b_data - a_data Then tbl(i, n) = ary(n) tbl(i, n + 1) = ary(n + t) If i Mod a_data = 0 Then t = t + 1 End If Else tbl(i, n) = ary(n + 1) tbl(i, n + 1) = ary(n + 1 + f) If i Mod c_data = 0 Then f = f + 1 End If End If End If Next i ElseIf n = 3 Then If data = 10 Then For i = 1 To UBound(tbl, 1) If i <= a_data Then tbl(i, n) = 3 Else tbl(i, n) = 2 End If Next i For i = 1 To UBound(tbl, 1) r = 1 dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, 4) = ary(s) r = s + 1 If i Mod c_data = 0 Then dic(ary(s)) = Empty End If Exit For End If Next s If i Mod a_data = 0 Then dic.removeall Next i For i = 1 To UBound(tbl, 1) Step 15 dic(tbl(i, 1)) = Empty dic(tbl(i, 2)) = Empty dic(tbl(i, 3)) = Empty dic(tbl(i, 4)) = Empty For s = 1 To UBound(ary) If Not dic.exists(ary(s)) Then flg = True r = s + 1 For b = i To i + 15 - 1 tbl(b, 5) = ary(s) dic(ary(s)) = Empty For t = r To UBound(ary) If Not dic.exists(ary(t)) Then Cnt = Cnt + 1 tbl(b, 6) = ary(t) If Cnt = 3 Then dic(ary(t)) = Empty Cnt = 0 r = t + 1 End If Exit For End If Next t Next b End If If flg Then dic.removeall: flg = False: Exit For Next s Next i For i = 1 To UBound(tbl, 1) Step 3 dic.removeall For j = 1 To UBound(tbl, 2) - 4 dic(tbl(i, j)) = Empty Next j For s = 1 To UBound(ary) If Not dic.exists(ary(s)) Then flg = True r = s + 1 For b = i To i + 3 - 1 tbl(b, 7) = ary(s) dic(ary(s)) = Empty For t = r To UBound(ary) If Not dic.exists(ary(t)) Then tbl(b, 8) = ary(t) dic(ary(t)) = Empty r = t + 1 Exit For End If Next t Next b End If If flg Then flg = False: Exit For Next s Next i For i = 1 To UBound(tbl, 1) dic.removeall For j = 1 To UBound(tbl, 2) - 2 dic(tbl(i, j)) = Empty totl = totl + tbl(i, j) Next j For s = 1 To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, 9) = ary(s) tbl(i, 10) = 55 - (totl + tbl(i, 9)) Exit For End If Next s totl = 0 Next i ElseIf data = 9 Then t = 0 For p = 1 To UBound(tbl, 1) Select Case p Case 91, 196, 841 t = 1 Case 301, 406, 511, 616, 721, 826, 856 t = 0 Case 106, 211, 316, 421, 526, 631, 736 t = -1 End Select tbl(p, n) = ary(n + t) Next p t = 1 For p = 1 To UBound(tbl, 1) Select Case p Case 16 To 90, 106 To 195, 211 To 300, 316 To 405, 421 To 510, _ 526 To 615, 631 To 720, 736 To 825 If p Mod 15 = 1 Then t = IIf(p = 106, 1, IIf(p = 211 Or p = 316 Or p = 421 Or p = 526 Or _ p = 631 Or p = 736, 0, IIf(p = 226, 2, _ IIf(p = 346, 3, _ IIf(p = 466 Or p = 892, 4, _ IIf(p = 586 Or p = 625 Or p = 910, 5, _ IIf(p = 706, 6, t + 1))))))) End If Case 91 To 105, 196 To 210, 301 To 315, 406 To 420, 511 To 525, _ 616 To 630, 721 To 735, 826 To 945 If p Mod 3 = 1 Then t = IIf(p = 91 Or p = 196 Or p = 301 Or p = 841 Or p = 856, 2, _ IIf(p = 406 Or p = 511 Or p = 616 Or p = 721 Or p = 826 _ Or p = 871 Or p = 886 Or p = 901 Or p = 916 Or p = 931, 1, _ IIf(p = 409 Or p = 874, 3, IIf(p = 517 Or p = 892, 4, _ IIf(p = 625 Or p = 910, 5, IIf(p = 733 Or p = 928, 6, t + 1)))))) End If End Select tbl(p, n + 1) = ary(n + t) Next p End If End If If n = 5 Then If data = 9 Then For p = 1 To UBound(tbl, 1) Select Case p Case 1 To 12, 43 To 45, 58 To 60, 73 To 75, 88 To 90, 94 To 117, 148 To 150, _ 163 To 165, 178 To 180, 193 To 195, 199 To 222, 253 To 255, 268 To 270, _ 283 To 285, 298 To 300, 304 To 315, 433 To 435, 448 To 450, 511 To 513, _ 538 To 540, 553 To 555, 616 To 618, 643 To 645, 658 To 660, 721 To 723, _ 748 To 750, 763 To 765, 826 To 828, 844 To 855, 859 To 870, 886 To 888, _ 901 To 903, 916 To 918, 931 To 933 t = 0 Case 13 To 15, 28 To 30, 91 To 93, 118 To 120, 133 To 135, 195 To 198, _ 223 To 225, 238 To 240, 301 To 303, 328 To 330, 343 To 345, _ 406 To 408, 841 To 843, 856 To 858, 871 To 873 t = 1 Case 16 To 27, 31 To 42, 46 To 57, 61 To 72, 76 To 87, 121 To 132, 136 To 147, _ 151 To 162, 166 To 177, 181 To 192, 316 To 327, 358 To 360, 373 To 375, _ 388 To 390, 403 To 405, 409 To 432, 463 To 465, 478 To 480, 493 To 495, _ 508 To 510, 514 To 537, 568 To 570, 583 To 585, 598 To 600, 613 To 615, _ 619 To 642, 673 To 675, 688 To 690, 703 To 705, 718 To 720, 724 To 747, _ 778 To 780, 793 To 795, 808 To 810, 823 To 825, 829 To 840, 874 To 885, _ 889 To 900, 904 To 915, 919 To 930, 934 To 945 t = -1 Case 226 To 237, 241 To 252, 256 To 267, 271 To 282, 286 To 297, 331 To 342, _ 346 To 357, 361 To 372, 376 To 387, 391 To 402, 436 To 447, 451 To 462, _ 466 To 466, 481 To 492, 496 To 507, 541 To 552, 556 To 567, 571 To 582, _ 586 To 597, 601 To 612, 646 To 657, 661 To 672, 676 To 687, 691 To 702, _ 706 To 717, 751 To 762, 766 To 777, 781 To 792, 796 To 807, 811 To 822 t = -2 End Select tbl(p, n) = ary(n + t) Next p c = 1 dic.removeall For i = 1 To UBound(tbl, 1) For w = 1 To 5 dic(tbl(i, w)) = Empty Next w For s = 1 To UBound(ary) If Not dic.exists(ary(s)) And tbl(i, 5) < ary(s) Then tbl(i, 6) = ary(s) If i > a_data * (data - 1) Then dic(tbl(i, 6)) = Empty If i Mod 3 = 0 Then dic.removeall Exit For End If ElseIf i Mod 3 = 0 Or flg Then dic(tbl(i, 6)) = Empty Select Case i Case 93, 96, 99, 102, 198, 201, 204, 207, 303, 306, 309, _ 312, 408, 411, 414, 417, 513, 516, 519, 522, 618, 621, _ 624, 627, 723, 726, 729, 732, 828, 831, 834, 837 dic.removeall End Select End If Exit For End If Next s If i = 15 * g + 12 Then g = g + 1 dic.removeall flg = True End If If i Mod 15 = 0 Then dic.removeall c = c + 1 Select Case i Case 90, 195, 300, 405, 510, 615, 720 flg = True Case Is >= 825 flg = True Case Else flg = False End Select End If If i Mod ((a_data * c) - c_data) = 0 Or i Mod a_data = 0 Then c = IIf(i Mod ((a_data * c) - c_data) = 0, c + 1, c) dic.removeall End If If i > a_data * (data - 1) And i Mod c_data = 0 Then dic.removeall End If If i = a_data * (data - 1) Then For j = 1 To data - 1 ary(j) = ary(j + 1) Next j End If Next i g = 0 flg = False For j = 1 To data ary(j) = j Next j c = 1 For i = 1 To UBound(tbl, 1) For j = 1 To 6 dic(tbl(i, j)) = Empty Next j If flg Then dic(tbl(i - 3, 5)) = Empty End If If flg1 Then dic(swap) = Empty End If r = 1 For j = 7 To 8 For s = r To UBound(ary) If Not dic.exists(ary(s)) Then tbl(i, j) = ary(s) r = s + 1 Exit For End If Next s Next j dic.removeall If i < a_data * (data - 1) Then If i Mod 15 = 12 Or i Mod 15 = 13 Or i Mod 15 = 14 Then flg = True Else If Not flg1 Then Select Case i Mod 3 Case 1 dic(tbl(i, 8)) = Empty Case 2 dic(tbl(i, 7)) = Empty Case Else dic.removeall End Select End If End If If i = 15 * g + 12 - 1 Then g = g + 1 dic(tbl(i - 3, 5)) = Empty flg = True End If If i Mod 15 = 0 Then Select Case i Case 90 swap = 3 flg1 = True flg = False Case 195, 300, 405, 510, 615, 720, 825 swap = 2 flg1 = True flg = False Case Is >= 840 swap = 1 flg1 = True flg = False Case Else flg = False flg1 = False End Select End If If i Mod a_data = 0 Or i Mod ((a_data * c) - c_data) = 12 Or i _ Mod a_data = 13 Or i Mod a_data = 14 Then dic(tbl(i - 3, 5)) = Empty c = IIf(i Mod ((a_data * c) - c_data) = 0, c + 1, c) End If End If If i = a_data * (data - 1) Then For j = 1 To data - 1 ary(j) = ary(j + 1) Next j flg = False flg1 = False End If Next i End If Exit For End If Next n End Select ReDim x(1 To UBound(tbl, 1), 1 To UBound(tbl, 2) \ 2) t = 0 For i = 1 To UBound(tbl, 1) For n = 1 To (UBound(tbl, 2) \ 2) * 2 Step 2 t = t + 1 x(i, t) = tbl(i, n) & "," & tbl(i, n + 1) Next n t = 0 Next i .Cells(1, 1).Resize(UBound(tbl, 1), UBound(x, 2)) = x End With Set dic = Nothing End Sub Sub e_data(data) Select Case data Case 7 a_data = 15 b_data = 105 c_data = 3 Case 8 a_data = 15 b_data = 105 c_data = 3 Case 9, 10 a_data = 105 b_data = 945 c_data = 15 End Select End Sub Sub over_size(data, ary, data_over) Dim dic As Object, dic1 As Object, j As Integer, i As Integer, b As Integer Dim n As Integer, m As Integer, t, x, tbl, tbl1, s Dim mei As String, col As Integer, swap As Integer Randomize Set dic1 = CreateObject("scripting.dictionary") Set dic = CreateObject("scripting.dictionary") ReDim tbl(1 To 1, 1 To data - data Mod 2) ReDim tbl1(1 To data_over, 1 To data - data Mod 2) For j = 1 To UBound(tbl1, 1) i = 0 Do While i < data - 1 i = i + 1 tbl(1, i) = Int(Rnd * data) + 1 If dic.exists(tbl(1, i)) Then i = i - 1 Else dic(tbl(1, i)) = Empty End If Loop If data Mod 2 = 0 Then tbl(1, data) = WorksheetFunction.Sum(ary) - WorksheetFunction.Sum(tbl) For n = 1 To data - data Mod 2 Step 2 If tbl(1, n) > tbl(1, n + 1) Then swap = tbl(1, n) tbl(1, n) = tbl(1, n + 1) tbl(1, n + 1) = swap End If Next n ReDim x(1 To data \ 2) m = 0 For i = 1 To data - data Mod 2 Step 2 m = m + 1 x(m) = tbl(1, i) Next i b = 1 For i = 1 To data \ 2 tbl1(j, b) = WorksheetFunction.Small(x, i) t = WorksheetFunction.Match(tbl1(j, b), x, 0) tbl1(j, b + 1) = tbl(1, WorksheetFunction.Match(WorksheetFunction.Small(x, i), x, 0) * 2) b = b + 2 Next i ReDim s(1 To data \ 2) m = 0 For col = 1 To data - data Mod 2 Step 2 m = m + 1 s(m) = tbl1(j, col) & "-" & tbl1(j, col + 1) Next col mei = Join(s, ",") If Not dic1.exists(mei) Then dic1(mei) = Empty Else i = i - 1 End If dic.removeall tbl(1, UBound(tbl, 2)) = Empty Next j ReDim x(1 To UBound(tbl1, 1), 1 To UBound(tbl1, 2) \ 2) t = 0 For i = 1 To UBound(tbl1, 1) For n = 1 To (UBound(tbl1, 2) \ 2) * 2 Step 2 t = t + 1 x(i, t) = tbl1(i, n) & "," & tbl1(i, n + 1) Next n t = 0 Next i Sheets("sheet1").Cells(1, 1).Resize(UBound(tbl1, 1), UBound(x, 2)) = x Set dic = Nothing Set dic1 = Nothing End Sub Sub 並べ替え() Dim i As Long, n As Integer, t As Integer, j As Long, Court_Num As Integer, tbl, x With Sheets("sheet1") tbl = .Cells(1, 1).Resize(.Cells(Rows.Count, 1).End(xlUp).Row, _ .Cells(1, Columns.Count).End(xlToLeft).Column) Court_Num = Val(StrConv(InputBox("コート数は？"), vbNarrow)) If Court_Num = 0 Then Exit Sub ReDim x(1 To ((UBound(tbl, 2) \ Court_Num + IIf(UBound(tbl, 2) Mod Court_Num, _ 1, 0)) + 1) * UBound(tbl, 1), 1 To Court_Num) For i = 1 To UBound(tbl, 1) For n = 1 To UBound(tbl, 2) If n Mod Court_Num = 1 Then j = j + 1 End If t = IIf(n Mod Court_Num = 1, 1, t + 1) x(j, t) = tbl(i, n) Next n t = 0 j = j + 1 Next i End With With Sheets("sheet2") .Cells.ClearContents .Cells(1, 1).Resize(j, UBound(x, 2)) = x End With End Sub ---- インデント不細工の為書き換え9/30 19:52 （弥太郎） ---- 充実した生活とのこと　お喜びします。 お蔭様で私も毎日充実した生活を楽しんでいます。 さて、 弥太郎さんの↑マクロを １、１８人で遊ぶ ２、３組拾う で実行してできた表を、 その後　別のインプットボックスに列数を入力して、 並替をしたい。(Ty) インプットボックスに「４」と入力して （４コート分の対戦表作成する） シート１のa1:d1を　シート２のa1:d1へ シート１のe1:h1を　シート２のa2:d2へ シート１のi1 を　シート２のa3 へ シート１のa2:d2を　シート２のa5:d5へ シート１のe2:h2を　シート２のa6:d6へ シート１のi2 を　シート２のa7 へ シート１のa3:d3を　シート２のa9:d9へ シート１のe3:h3を　シート２のa10:d10へ シート１のi3 を　シート２のa11 へ に並び替えたい。 ご教示お願いします。 コート数は前もって決まっていますが、 参加者は当日集った人員で その場で対戦表を作りますので・・・ ---- Tyはん、いやバドはん、それともＴＯＭはんでっか？ お待たせしてすんまへんなぁ。 それにしても七変化のＨＮでんなぁ。（笑 ところで、コードを書き換えとりますんで、組合せを実行した後（Sheet1に抽出する よう変更）並び替えを実行してみてくらはい。 どうでっか？こんな塩梅で？ せやけど、これはランダムに抽出しとりますんで僅か３組のセットといえども同じペアと組む 弊害が出てきますワ。 まぁ、お目当ての美人と２度３度ペアを組めるんなら何の依存もない殿方も居てまっし しゃろけど、そうでない御方と何度もペアを組むのは・・・っちゅう不届きな殿方も居 てはりまっしゃろから、今少し改良が必要と思われます。 それと、Ty（バド、TOM）はんのケースやと、全組合せは寧ろ邪魔になりまっしゃろか ら、それも改善する必要がありますわなぁ。 つまり、ランダムで且つ２度と美人とペアにならないような組合せが・・・。 ま、それは追々考えまひょ。 　　　　（弥太郎） ---- 完璧です。 ありがとうございました。 バドさん、ＴＯＭさん、弥太郎さん　すみませんでした。 本ログに挨拶もせずに横はいりし　誤解をされたようです。 　　(Ty)は(Ty)のＨＮのみ使用しています。 同じペアの組合せの時は カウントイフと条件書式にてチェックし 組合せを変更し使用しています。 同じ趣味を持つ方は　このマクロを利用されるのではかと 思いますので、２度と同ペアにならない方法があれば、 次の機会にでもご教示ください。 ありがとうございました。 (Ty) ---- 次の機会と申さずに鉄は熱い内に打っときまひょぅ。＾＾ ただ、はねられたペアを優先的に次に廻すという芸はまだ拾うするに至っておりまへん。 Tｙはんのやりかたやと、寧ろこの方がええのかもしれまへんなぁ。 これで同組の難点はかなり緩和されとると思うんですが・・・ 　　　　　（弥太郎） '------------------------------ Option Explicit Sub バドミントン() Dim dic As Object, j As Integer, i As Integer, p As Integer, u As Integer Dim n As Integer, data As Integer, Cnt As Integer, x, tbl, rnk, y, b_data As Integer Dim pic_data As Integer, t As Integer, w As Integer, f As Integer Randomize Set dic = CreateObject("scripting.dictionary") data = Val(StrConv(InputBox("何人で遊びまっか？"), vbNarrow)) pic_data = Val(StrConv(InputBox("何組ほど拾いまひょ？"), vbNarrow)) If pic_data * data = 0 Then MsgBox "入力不正！": Exit Sub Select Case data Case 5, 6: b_data = 15 Case 7, 8: b_data = 105 Case 9, 10: b_data = 945 Case Is > 10: b_data = 1500 End Select If b_data < pic_data Then MsgBox "それは正確なデータが抽出でけまへん": Exit Sub ReDim rnk(1 To data) ReDim y(1 To 2) ReDim x(1 To pic_data, 1 To data \ 2) For j = 1 To pic_data For p = 1 To data rnk(p) = Rnd Next p w = 0 i = 0 Do While i < data - data Mod 2 t = t + 1 i = i + 1 y(t) = Application.Match(WorksheetFunction.Large(rnk, i), rnk, 0) If i Mod 2 = 0 Then w = w + 1 x(j, w) = IIf(y(1) > y(2), y(2) & "," & y(1), Join(y, ",")) If Not dic.exists(x(j, w)) Then dic(x(j, w)) = Empty Else For u = w To 1 Step -1 If u <> w Then dic.Remove x(j, u) x(j, u) = Empty Next u For f = 1 To data rnk(f) = Rnd Next f Cnt = Cnt + 1 If Cnt = data * 10 Then dic.RemoveAll: Cnt = 0 i = 0 w = 0 End If t = 0 End If Loop If j = WorksheetFunction.Combin(data, 2) / (data \ 2) Then dic.RemoveAll End If Next j With Sheets("sheet1") .Cells.ClearContents .Cells(1, 1).Resize(UBound(x, 1), UBound(x, 2)) = x End With 並べ替え Set dic = Nothing End Sub Sub 並べ替え() Dim i As Long, n As Integer, t As Integer, j As Long, Court_Num As Integer, tbl, x With Sheets("sheet1") tbl = .Cells(1, 1).Resize(.Cells(Rows.Count, 1).End(xlUp).Row, _ .Cells(1, Columns.Count).End(xlToLeft).Column) Court_Num = Val(StrConv(InputBox("コート数は？"), vbNarrow)) If Court_Num = 0 Then Exit Sub ReDim x(1 To ((UBound(tbl, 2) \ Court_Num + IIf(UBound(tbl, 2) Mod Court_Num, _ 1, 0)) + 1) * UBound(tbl, 1), 1 To Court_Num) For i = 1 To UBound(tbl, 1) For n = 1 To UBound(tbl, 2) If n Mod Court_Num = 1 Then j = j + 1 End If t = IIf(n Mod Court_Num = 1, 1, t + 1) x(j, t) = tbl(i, n) Next n t = 0 j = j + 1 Next i End With With Sheets("sheet2") .Cells.ClearContents .Cells(1, 1).Resize(j, UBound(x, 2)) = x End With End Sub ---- 期待どおりの表がサクサクできました。 弥太郎さんには不可能という言葉がない、 ということがよくわかりました。 ありがとうございます。 (Ty)