gooID利用規約 改定のお知らせ

テニスサークル運営のための、テニスの組み合わせの乱数表をつくりたいのですが、以前、投稿されていた質問の回答通りにやってみたのですが(QNo.1388951 テニス乱数表)このマクロには大切なことが抜けてるみたいです。同じ人とのペアが何度もできてしまいます。
・10から14人で
・2つのコート使用で
・同じ人が連続で休まない
・なるべく同じ人とペアを組まない(←ここが入ってたら問題なかったのですが)
わかる方いらっしゃいましたらどうかよろしくお願いします!

このQ&Aに関連する最新のQ&A

A 回答 (1件)

こんにちは。



新しく作ってみました。

<使い方>
 1)B1に参加者の数
   B2にコートの数
   B3に各コートでの試合数
   B4にペアの重複を禁止する過去の試合数 を入力
 2)以下のマクロを標準モジュールに登録して実行

<注意点>
 1)試合数や重複禁止の試合数を大きくすると計算に時間がかかります。
   場合によっては解が得られません。その場合は条件を緩めてください。
 2)実際に試合をしている人よりも待機している人の方が多い場合
   は考慮していません。計算はしますが同じ人が連続して休むかも
   しれません。コート数を増やしてください。

'<マクロ>-----------------------------------------------------
Sub test()
On Error GoTo ERR

 Dim R As Integer
 Dim R0 As Integer
 Dim C As Integer
 Dim i As Integer
 Dim X As Integer
 Dim X0 As Integer
 Dim k As Integer
 Dim ctRestart As Integer
 Dim ctRetry As Integer
 Dim flg As Integer
 Dim Try_Val As Integer '乱数試行値
 Dim Member As Integer '参加メンバー
 Dim Player As Integer '試合中の選手の数
 Dim Standby As Integer '待機中の選手の数
 Dim Court As Integer 'コートの数
 Dim GameNo As Integer '各コートの試合数

 Range("C:IV").ClearContents
 Range("E1").Value = "計算中"
 Range("A1").Value = "参加者:"
 Range("A2").Value = "コート数:"
 Range("A3").Value = "試合数:"
 Range("A4").Value = "重複禁止:"

 Application.ScreenUpdating = False

StartLine:
 ctRestart = ctRestart + 1
 If ctRestart > 1000 Then GoTo ERR

 '//定数
 Member = Range("B1").Value '参加メンバー
 Court = Range("B2").Value 'コートの数
 GameNo = Range("B3").Value '各コートの試合数
 X0 = Range("B4").Value 'ペアの重複を禁止する試合数

 If WorksheetFunction.Count(Range("B1:B4")) <> 4 Then GoTo ERR
 If Member < 4 Then GoTo ERR
 If Court < 1 Then GoTo ERR
 If GameNo < 1 Then GoTo ERR
 If X0 < 1 Then GoTo ERR
 If GameNo < X0 Then GoTo ERR

 Player = Court * 4 '試合中の選手の数
 Standby = Member - Player '待機中の選手の数

 '第1試合のチーム分け
 Cells(1, "C").Value = Int(Rnd() * Member + 1)
 For R = 2 To Player
  flg = 0
  Do
   Try_Val = Int(Rnd() * Member + 1)
   For k = 1 To R - 1
    If Cells(k, "C").Value = Try_Val Then Exit For
    If k = R - 1 Then flg = 1
   Next k
  Loop Until flg = 1
  Cells(R, "C").Value = Try_Val
 Next R
 For R = 2 To Player Step 2
  Cells(R, "D") = Cells(R - 1, "C") & "_" & Cells(R, "C")
 Next R

 '第2試合以降のチーム分け
 For i = 1 To GameNo - 1
  For R = Player * i + 1 To Player * (i + 1)
   flg = 0
   ctRetry = 0
   Do
Retry:
    Try_Val = Int(Rnd() * Member + 1)
    ctRetry = ctRetry + 1
    If ctRetry > Player * 4 Then GoTo StartLine
    X = Int((R - 1) / Player)
    If (R Mod Player) > 0 And (R Mod Player) <= Standby Then
     For k = (X - 1) * Player + 1 To R - 1
      If Cells(k, "C").Value = Try_Val Then GoTo Retry
     Next k
    Else
     For k = X * Player + 1 To R - 1
      If Cells(k, "C").Value = Try_Val Then GoTo Retry
     Next k
    End If
    If R Mod 2 = 0 Then
     If (X - X0) * Player + 1 < 1 Then
      R0 = 1
     Else
      R0 = (X - X0) * Player + 1
     End If
     For k = R0 To R
      If Try_Val & "_" & Cells(R - 1, "C") = Cells(k, "D") Or _
       Cells(R - 1, "C") & "_" & Try_Val = Cells(k, "D") Then
       If ctRetry < Player * 2 Then
        GoTo Retry
       Else
        Range(Cells(Player * i + 1, "C"), Cells(R, "C")).ClearContents
        R = Player * i + 1
        GoTo Retry
       End If
      End If
     Next k
    End If
    flg = 1
   Loop Until flg = 1
   Cells(R, "C").Value = Try_Val
  Next R
  For R = Player * i + 2 To Player * (i + 1) Step 2
   Cells(R, "D") = Cells(R - 1, "C") & "_" & Cells(R, "C")
  Next R
 Next i

 '対戦表の作成
 For C = 1 To Court
  Cells(1, C + Range("E1").Column).Value = "第" & C & "コート"
 Next C
 For i = 1 To GameNo
  Cells(i + 1, "E").Value = "第" & i & "試合"
  For C = 1 To Court
   Cells(i + 1, C + Range("E1").Column).Value = _
    Format(Cells((i - 1) * Player + (C - 1) * 4 + 1, "C"), "00") & "_" & _
    Format(Cells((i - 1) * Player + (C - 1) * 4 + 2, "C"), "00") & " VS " & _
    Format(Cells((i - 1) * Player + (C - 1) * 4 + 3, "C"), "00") & "_" & _
    Format(Cells((i - 1) * Player + (C - 1) * 4 + 4, "C"), "00")
  Next C
 Next i
 Range("E1").Value = ""
 ActiveSheet.UsedRange.EntireColumn.AutoFit
 Columns("C:D").EntireColumn.Hidden = True
 Application.ScreenUpdating = True
 Exit Sub

ERR:
 Application.ScreenUpdating = True
 Range("E1").Value = "エラー"
 MsgBox "入力値を再設定してください"

End Sub
    • good
    • 0
この回答へのお礼

ka_na_deさん、複雑なマクロ本当にありがとうございます。
何パターンか試してみてみたいと思います。

これをきっかけに、私もエクセルにすごく興味がでてきました。
マクロを作れるくらいになりたいです。

本当にありがとうございました!

お礼日時:2007/07/29 14:30

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング