[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『テニスダブルスの組合せ』（ＴＯＭ）
内容は
テニスのダブルスの組合せで、毎回参加人数が違うのですが最後に、みんなで、試合をします。参加者全員が、満遍なく対戦し、毎回ダブルスを組ペアも違うよいうに組合せを考えたいのですが、エクセルでは計算できませんかね??
例えば、Ａ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)<row() 書式フォント 白 ((()))
弥太郎さん、こんにちは〜。 お忙しい中の即レスありがとうございますm(__)m
できました♪ コード書き込んだ後のマクロの実行（Alt+F8）をしてませんでした(汗)。 また一つ勉強させて頂きました。ありがとうございます。
ＴＯＭさん、スレお借りしてごめんなさい。 マクロ実行できましたでしょうか？ かくいう私もたった今できたばかりですが・・・^^
((()))さん、こんにちは！ 関数試してみました。。。 組合せの一部・・・ということですよね。総数は×３となる気がしますが・・・。 勘違いしていたらごめんなさい。。。
(ぎょたく)
弥太郎さんの上記マクロを実行してできた表(シート１)を、 その後 別のインプットボックスに列数を入力して、 シート２へ並替をしたい。ご教示ください。(Ty)
インプットボックスに「８」と入力して シート１のa1:r3（18列）の数値の １行目の数値を シート２のa1:h3へ（８列） ２行目の数値を シート２のa5:h7へ ３行目の数値を シート２のa9:h11へ（c11:h11は空欄となる）
また、ある時は インプットボックスに「６」と入力して シート１のa1:z3（26列）の数値の １行目の数値を シート２a1:f5へ（６列） ２行目の数値を シート２a7:f11へ ３行目の数値を シート２a13:f17へ（c17:f17は空欄となる） と並び替えたい
えと、弥太郎はんのマクロは日進月歩、現在は↑の様なマクロは手持ちにありまへん。
下のマクロを実行した後にどうなさりたいんか再度掲載願います。
但し、忙しくて充実した毎日を送っておりますんで、時間が許されればっちゅう条件
でよろしければの話ですけど・・・。
（弥太郎）
'------------------------
Option Explicit
Public c_data As Integer, data As Integer, tbl
Public a_data As Integer, b_data As Integer
Sub 組合せ()
Dim dic As Object, i As Long, t As Long, data_over As Integer, x, w, s
Dim c As Integer, r As Integer, n As Integer, f As Integer, ary
Dim j As Integer, Cnt As Integer, flg As Boolean, b As Integer, totl As Integer
Dim p As Long, m As Integer, g As Integer, flg1 As Boolean, swap As Integer
Set dic = CreateObject("scripting.dictionary")
data = Val(StrConv(InputBox("何人で遊びまっか？"), vbNarrow))
If data = 0 Then Exit Sub
e_data (data)
ReDim ary(1 To data)
For i = 1 To data
ary(i) = i
Next i
If data > 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)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.