[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『軟式テニスの組合せ表』（maki）
こんばんわ
何時も勉強させて頂いております。宜しくお願い致します。
軟式テニスの組合せ表を考えています 軟式については、前衛と後衛とポジンションが分かれており 硬式のダブルスの表には沢山いいものがありましたが 使うことは出来ませんでした。(硬式は、前衛・後衛の分けが無く人数でランダムに可能のため) そこで、以下の条件で組合せ表を作成したいのですが ご教授いただければ幸いです。宜しくお願い致します。
・できるだけ、違う人とペアを組む ・できるだけ、各メンバの平均試合数を同じにする ・できるだけ、連続して休まないようにする ・使用するコートは１面で実施する
人数は、日々出席者がまちまちです 9人から20人まで作成したいと思っているのです。 少ない人数ですと、マンパワーで出来ます。 もしかすると、想像もつかない位難しいことなのかも知れません マンパワーで作成しましたものを掲載させていただきます
前衛 後衛 前衛 後衛 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 前衛・後衛4人の場合 前衛5人・後衛4人の場合 縦に見ていただき、前衛と後衛にそれぞれ番号をつけ 組み合せます。 以下の事例は、前衛の1番と後衛の1番が組み合い 前衛の2番と後衛の2番が組み合い戦うと言うイメージです
前衛 後衛 前衛 後衛 1試合目 1 1 1 1 2 2 2 2 2試合目 3 3 3 3 4 4 4 4 3試合目 1 2 5 1 3 4 1 2 4試合目 2 3 2 3 4 1 3 4 5試合目 1 3 4 1 2 4 5 2 6試合目 3 1 1 3 4 2 3 1 7試合目 1 4 2 4 4 3 4 2 8試合目 2 1 5 3 3 2 2 1
3 2 5 4
1 4 4 3 どうぞ宜しくお願い致します。 （maki）
軟式はやったことがないので、再確認させて下さい。
軟式の前衛とか後衛とかは、固定なのですか？ つまり、前衛をやる人は、後衛のポジションはやらない、 と云うことなんでしょうか？
もし固定なら、硬式のミックスと同じ考え方でいけるのですが・・・
(半平太) 2011/09/26 09:25
＞軟式の前衛とか後衛とかは、固定なのですか？ つまり、前衛をやる人は、後衛のポジションはやらない、 と云うことなんでしょうか？
はい、やりません。固定です。
＞もし固定なら、硬式のミックスと同じ考え方でいけるのですが・・・
そうですか。考えたのですが、うまく理解ができなくって 本当に回答有難う御座います （maki）
１．Sheet1のシート名を「Main」、Sheet2のシート名を「Work」としてください。
２．標準モジュールを以下の手順で１つ挿入してください。 (ALT+F11としてVBE表示)→VBEメニュー[挿入]→[標準モジュール]
後記コードをコピペしてください。
３．クラスモジュールを以下の手順で二つ挿入してください。 プロパティウィンドウからクラス名をそれぞれ「MatchArranger」「Player」として下さい。
それぞれに、後記コードをコピペしてください。
４．Mainシートに所要計数を入力してください。 <Main>今回の例 行 ______A______ _B_ ___C___ 1 参加人数 9 必須 ←「前衛」+「後衛」 2 コート数 1 必須 3 回戦数 8 必須 ← 使用時間と参加人数から適当に割り出して(でも必ず)入れてください。 4 前衛(軟式時) 5 Option
５．Mainシートにマクロ実行ボタンを作って、マクロ「Pairing」を登録し、クリックしてみてください。
<Main>実行後の結果例 行 _______A_______ ___B___ ___C___ ___D___ ___E___ _F_ ___G___ _H_ ___I___ _J_ ___K___ _L_ ___M___ ___N___ ___O___→右へつつく 1 参加人数 9 必須 2 コート数 1 必須 3 回戦数 8 必須 4 前衛(軟式時) 5 Option 5 6 7 8 9 氏名(前衛が先) 背番号 出場数 対戦表 第1 出番表 氏名01 氏名02 10 氏名01 1 3 1回戦 7 - 5 対 9 - 4 1回戦 11 氏名02 2 4 2回戦 3 - 6 対 2 - 8 2回戦 1 12 氏名03 3 3 3回戦 1 - 9 対 7 - 4 3回戦 1 13 氏名04 4 3 4回戦 6 - 5 対 8 - 3 4回戦 14 氏名05 5 3 5回戦 2 - 7 対 1 - 8 5回戦 1 1 15 氏名06 6 4 6回戦 3 - 9 対 6 - 4 6回戦 16 氏名07 7 4 7回戦 1 - 7 対 2 - 9 7回戦 1 1 17 氏名08 8 4 8回戦 5 - 8 対 2 - 6 8回戦 1 18 氏名09 9 4 19 対戦表 第1 同ペア 氏名01 氏名02 20 1回戦 氏名07 - 氏名05 対 氏名09 - 氏名04 氏名01 21 2回戦 氏名03 - 氏名06 対 氏名02 - 氏名08 氏名02 22 3回戦 氏名01 - 氏名09 対 氏名07 - 氏名04 氏名03 23 4回戦 氏名06 - 氏名05 対 氏名08 - 氏名03 氏名04 24 5回戦 氏名02 - 氏名07 対 氏名01 - 氏名08 氏名05 25 6回戦 氏名03 - 氏名09 対 氏名06 - 氏名04 氏名06 1 26 7回戦 氏名01 - 氏名07 対 氏名02 - 氏名09 氏名07 1 1 27 8回戦 氏名05 - 氏名08 対 氏名02 - 氏名06 氏名08 1 1 28 氏名09 1 1
氏名を具体的に出したい場合は、A10セル以下前衛から書いて下さい。 名前が分かっている人だけ書いてもいいです。(書いた人は実名で対戦表に出ます)
実際に私が使っているものです。 欠点は、対戦相手が同じ様な顔ぶれになること迄は考慮していないことです。 まぁ、そんなことで待ち時間を長くされると不機嫌になるプレーヤもいますから、止むを得ないかもです。
'標準モジュールに貼り付けるコード-----------------------
Public Const Main As String = "Main" Public Const Work As String = "Work"
Public numTotalPlayers Public numOfCourts As Long Public lastRound As Long Public numOfFemale As Long Public maxPlayersOnCourt As Long Public absoluteBestScore As Double
Sub Pairing()
Dim wsMain As Worksheet
Dim MatchArranger As MatchArranger Dim Players() As Player
Dim matchschedule As Variant
Dim NN As Long, MM As Long, KK As Long Dim SS As Long, TT As Long
With Worksheets(Main)
If .Range("B1").Value < 4 Or _
.Range("B2").Value < 0 Or _
.Range("B2").Value < 1 Then
Exit Sub
End If
End With
Application.ScreenUpdating = False
With Worksheets(Main)
.Range("D10:AZ200").ClearContents
numTotalPlayers = .Range("B1").Value
numOfCourts = .Range("B2").Value
With WorksheetFunction
numOfCourts = .Min(numOfCourts, Int(numTotalPlayers / 4))
End With
lastRound = .Range("B3").Value
numOfFemale = .Range("B4").Value
maxPlayersOnCourt = numOfCourts * 4
absoluteBestScore = absBestScore() '最適解のスコア算出
End With
Set MatchArranger = New MatchArranger
ReDim Players(1 To numTotalPlayers)
For NN = 1 To numTotalPlayers 'インスタンス生成
Set Players(NN) = New Player
Next NN
Rem MatchArrangerにPlayersを渡して、対戦表を受け取る
matchschedule = MatchArranger.makeDraw(Players)
Rem 表にして結果を表示
Call DisplayResult(matchschedule)
Application.ScreenUpdating = True
End Sub
Sub DisplayResult(ByVal matchschedule)
Dim NN As Long, RR As Long, CC As Long, SS As Long
Dim pairFore As Long
Dim PairBack As Long
Dim plDecke As Long
Dim nameArys As Variant
Dim 対戦表Deck()
Dim 対戦表Name()
Dim 同ペアdisp()
Dim 出番disp()
Dim inputItem
With Worksheets(Main)
.Range("B10:C200").ClearContents
.Range("A9:C9").Value = [{"氏名(女性が先)","背番号","出場数"}]
nameArys = .Range("A10:C200").Value
For NN = 1 To numTotalPlayers '氏名欄を自動補充
If nameArys(NN, 1) = "" Then
nameArys(NN, 1) = Format(NN, "氏名00")
End If
nameArys(NN, 2) = NN
Next NN
ReDim 対戦表Deck(lastRound, maxPlayersOnCourt * 2)
ReDim 対戦表Name(lastRound, maxPlayersOnCourt * 2)
ReDim 出番表disp(lastRound, numTotalPlayers)
ReDim 同ペアdisp(numTotalPlayers, numTotalPlayers)
Rem タイトル
対戦表Deck(0, 0) = "対戦表"
対戦表Name(0, 0) = "対戦表"
出番表disp(0, 0) = "出番表"
同ペアdisp(0, 0) = "同ペア"
For NN = 1 To numOfCourts
対戦表Deck(0, NN * 8 - 4) = Format(NN, "第0")
対戦表Name(0, NN * 8 - 4) = Format(NN, "第0")
Next NN
For NN = 1 To numTotalPlayers
出番表disp(0, NN) = nameArys(NN, 1)
同ペアdisp(0, NN) = nameArys(NN, 1)
同ペアdisp(NN, 0) = nameArys(NN, 1)
Next NN
For NN = 1 To lastRound
出番表disp(NN, 0) = Format(NN, "0回戦")
Next NN
Rem 本体
For RR = 1 To lastRound
For CC = 1 To maxPlayersOnCourt
対戦表Deck(RR, CC * 2 - 1) = matchschedule(RR)(CC)
対戦表Name(RR, CC * 2 - 1) = nameArys(matchschedule(RR)(CC), 1)
plDecke = matchschedule(RR)(CC)
出番表disp(RR, plDecke) = 出番表disp(RR, plDecke) + 1
Next CC
For CC = 0 To maxPlayersOnCourt
If CC = 0 Then
inputItem = Format(RR, "0回戦")
Else
Select Case CC Mod 4
Case 0: inputItem = ""
Case 1: inputItem = "-"
Case 2: inputItem = "対"
Case 3: inputItem = "-"
End Select
End If
対戦表Deck(RR, CC * 2) = inputItem
対戦表Name(RR, CC * 2) = inputItem
Next CC
For CC = 1 To maxPlayersOnCourt Step 2
pairFore = matchschedule(RR)(CC)
PairBack = matchschedule(RR)(CC + 1)
同ペアdisp(pairFore, PairBack) = 同ペアdisp(pairFore, PairBack) + 1
同ペアdisp(PairBack, pairFore) = 同ペアdisp(PairBack, pairFore) + 1
nameArys(pairFore, 3) = nameArys(pairFore, 3) + 1
nameArys(PairBack, 3) = nameArys(PairBack, 3) + 1
Next CC
Next RR
Rem 出力および整形
With .Range("D9")
.Resize(200, 200).ClearContents
.Resize(200, 200).Offset(, 1).HorizontalAlignment = xlCenter
.Resize(lastRound + 1, maxPlayersOnCourt * 2 + 1).Value = 対戦表Deck
With .Offset(lastRound + 2, 0)
.Resize(lastRound + 1, maxPlayersOnCourt * 2 + 1).Value = 対戦表Name
End With
With .Offset(0, maxPlayersOnCourt * 2 + 1)
.Resize(lastRound + 1, numTotalPlayers + 1).Value = 出番表disp
End With
With .Offset(lastRound + 2, maxPlayersOnCourt * 2 + 1)
.Resize(numTotalPlayers + 1, numTotalPlayers + 1).Value = 同ペアdisp
End With
End With
.Range("A10:C200").Value = nameArys
.Columns("A:AZ").AutoFit
End With
End Sub
Function absBestScore() As Double
Dim sc1 As Double
Dim sc2 As Double
Dim sc3 As Double
Dim sc4 As Double
sc1 = maxPlayersOnCourt * lastRound
If numOfFemale < 1 Then
sc2 = numTotalPlayers * (numTotalPlayers - 1)
Else
sc2 = numOfFemale * (numTotalPlayers - numOfFemale) * 2
End If
sc3 = sc1 Mod sc2
sc4 = Int(sc1 / sc2)
absBestScore = (sc2 - sc3) * sc4 ^ 2 + sc3 * (sc4 + 1) ^ 2
End Function
'MatchArrngerクラスに貼り付けるコード--------------------------------
Public Sub refreshPlayersRec(ByRef Players)
Dim NN As Long
For NN = 1 To numTotalPlayers
Call Players(NN).setInitValue(NN, IIf(NN <= numOfFemale, 1, 2))
Next NN
End Sub
Public Function makeDraw(ByRef Players)
Const worstPoint As Double = 999999999# Dim wsf As WorksheetFunction Dim trialNo As Long Dim roundNo As Long
Dim NN As Long Dim MM As Long Dim KK As Long
Dim ownOrgckAry() Dim oneRoundPairing()
Dim bestScoreSofar As Double Dim resultScore As Double
Dim Wrec As Variant Dim isBestResult As Boolean
Set wsf = WorksheetFunction
ReDim oneRoundPairing(1 To lastRound)
ReDim ownOrgckAry(1 To numTotalPlayers, 1 To 2)
bestScoreSofar = worstPoint
For trialNo = 1 To 200 '最適解が見つかるまで20案作る
refreshPlayersRec (Players) '背番号と性別のみセット
For roundNo = 1 To lastRound 'ラウンド順に案を作成
Rem 選出考慮データUpdate
For NN = 1 To numTotalPlayers
ownOrgckAry(NN, 1) = Players(NN).numPlayed
ownOrgckAry(NN, 2) = Players(NN).Decke
Next NN
oneRoundPairing(roundNo) = pairingForOneRound(Players, ownOrgckAry) '一案作成
'ワンラウンド分の結果をPlayersのペア履歴に反映
For KK = 1 To maxPlayersOnCourt Step 2
Players(oneRoundPairing(roundNo)(KK)).updatePairingRec (oneRoundPairing(roundNo)(KK + 1))
Players(oneRoundPairing(roundNo)(KK + 1)).updatePairingRec (oneRoundPairing(roundNo)(KK))
Next KK
Next roundNo
Wrec = assessFactors(Players) '他のプレーヤーと何回組んだか調査
resultScore = wsf.SumProduct(Wrec, Wrec) '出来具合を数値化
If absoluteBestScore = resultScore Then
makeDraw = oneRoundPairing
isBestResult = True
Exit For
ElseIf resultScore < bestScoreSofar Then
bestScoreSofar = resultScore
makeDraw = oneRoundPairing
End If
Next trialNo
If isBestResult = False Then
MsgBox "最適解に達しませんでした。再トライすることをお勧めします"
End If
End Function
Private Function pairingForOneRound(ByRef Players, ByVal aryToChoose) Dim MM As Long
Dim maxSamePartner As Long Dim onePair() As Long '
ReDim onePair(1 To maxPlayersOnCourt) As Long
For MM = 1 To maxPlayersOnCourt Step 2
'出場回数で昇順並べ替え
aryToChoose = sortByTimesOfPlay(Players, aryToChoose)
'ペア記録Update
onePair(MM) = aryToChoose(1, 2)
onePair(MM + 1) = aryToChoose(2, 2)
aryToChoose(1, 1) = Empty
aryToChoose(2, 1) = Empty
Next MM
pairingForOneRound = onePair
End Function Private Function sortByTimesOfPlay(ByRef Players, ByRef ckary) Dim lastLiveRow As Long Dim cel As Range Dim playedWith As Variant Dim wsf As WorksheetFunction
With Sheets(Work)
.Range("A1:F1000").ClearContents
With .Range("A1:C" & UBound(ckary))
.Columns(1).Resize(, 2).Value = ckary
.Columns(3).Formula = ("=rand()")
.Columns(3).Value = .Columns(3).Value
.Columns(4).Formula = "=IF(B1>" & Main & "!$B$4,2,1)" '2=男性
.Columns(4).Value = .Columns(4).Value
End With
Rem 出場回数順にソート
.Range("A1:F1000").Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Key2:=.Range("C1"), Order2:=xlAscending, Header:=xlNo
lastLiveRow = .Range("A1000").End(xlUp).Row
If lastLiveRow = 1 Then
MsgBox "improper Players'Data. abort to process"
End
End If
Rem 1行目のプレーヤが2行目以下のプレーヤと何度組んだかをチェックして再ソート
playedWith = Players(.Range("B1").Value).recordsOfPlayedWith
Set wsf = WorksheetFunction
For Each cel In .Range("B2:B" & lastLiveRow)
cel.Offset(, 3).Value = WorksheetFunction.Index(playedWith, cel.Value)
Next
.Range("A2:E" & lastLiveRow).Sort Key1:=.Range("D2"), Order1:=IIf(.Range("D1").Value = 1, xlDescending, xlAscending), _
Key2:=.Range("A2"), Order2:=xlAscending, _
Key3:=.Range("E2"), Order3:=xlAscending, _
Header:=xlNo
sortByTimesOfPlay = .Range("A1:B" & .Range("A1000").End(xlUp).Row).Value
End With
End Function
Private Property Get assessFactors(ByRef Players) Dim NN As Long Dim MM As Long Dim aryToAssess() As Long
ReDim aryToAssess(1 To numTotalPlayers, 1 To numTotalPlayers)
For NN = 1 To numTotalPlayers
For MM = 1 To numTotalPlayers
aryToAssess(NN, MM) = Players(NN).timesPlayedwith(MM)
Next MM
Next NN
assessFactors = aryToAssess
End Property
'Playerクラスに貼り付けるコード-------------------------------- Private ownDecke As Long Private ownSex As Long Private ownNumPlayed As Long Private ownRecordsOfPlayedWith() As Long
Public Sub setInitValue(ByVal playerDecke As Long, ByVal playerSex As Long)
ownDecke = playerDecke
ownSex = playerSex
ownNumPlayed = 0
ReDim ownRecordsOfPlayedWith(1 To numTotalPlayers)
End Sub
Public Sub updatePairingRec(ByVal pairDecke As Long)
ownNumPlayed = ownNumPlayed + 1
ownRecordsOfPlayedWith(pairDecke) = ownRecordsOfPlayedWith(pairDecke) + 1
End Sub
Public Property Get Decke()
Decke = ownDecke
End Property
Public Property Get sex()
sex = ownSex
End Property
Public Property Get numPlayed()
numPlayed = ownNumPlayed
End Property
Public Property Get timesPlayedwith(ByVal pairDecke As Long) As Long
timesPlayedwith = ownRecordsOfPlayedWith(pairDecke)
End Property
Public Property Get recordsOfPlayedWith()
recordsOfPlayedWith = ownRecordsOfPlayedWith
End Property
(半平太) 2011/09/26 16:43
って申しますか、得体のしれない怪物のような モンスターマクロ有難うございます 正直理解するには、生きているうちには出来ないような。。 とにもかくにも、提示していただいたモンスターマクロ 実施結果報告させていただきます 本当に感謝いたします 有難うございます (maki)
> ３．クラスモジュールを以下の手順で二つ挿入してください。 > プロパティウィンドウからクラス名をそれぞれ「MatchArranger」「Player」として下さい。
以下の手順というのがなかった・・・・m(__)m
<訂正後> ３．クラスモジュールを以下の手順で二つ挿入してください。 (ALT+F11としてVBE表示)→VBEメニュー[挿入]→[クラスモジュール] プロパティウィンドウからクラス名をそれぞれ「MatchArranger」「Player」として下さい。
(半平太) 2011/09/26 22:33
ちょうど入力しているところでした ＞ ３．クラスモジュールを以下の手順で二つ挿入してください。 (ALT+F11としてVBE表示)→VBEメニュー[挿入]→[クラスモジュール] プロパティウィンドウからクラス名をそれぞれ「MatchArranger」「Player」として下さい。 本当にご親切に有難うござます この部分は読み取り、なんとか出来ました。 今は、以下のようなことに取り組んでいます
ばっちり動作しました 本当に感謝です。有難うございます ＞ 4 前衛(軟式時) 5 Option これが非常に大切です。助かりました。 奇数の場合、少ないほうを前衛に充てると ぴったりでした 素晴らしいしか言えません（生意気ですいません）
現在は、氏名欄を、前衛01、前衛02、後衛01、後衛02、後衛03 と直接入力した場合、何箇所か、組合せが逆になる 例えば、参加人数7、コート数1、試合数5、奇数整理3とした場合 参加人数 7 コート数 1 試合数 5 奇数整理 3 ←参加人数を2で割少ないほうを前衛に =ROUNDDOWN(B1/2,0) の場合以下のようになり 対戦表が一部逆になる現象を、数式で、別のシートに表記しようと考えています お名前 番号 試合数 対戦表 第1 前衛-1 1 3 1回戦 1 - 5 対 7 - 2 前衛-2 2 4 2回戦 4 - 3 対 6 - 2 前衛-3 3 3 3回戦 3 - 7 対 6 - 1 後衛-1 4 2 4回戦 5 - 3 対 4 - 2 後衛-2 5 3 5回戦 1 - 7 対 5 - 2 後衛-3 6 2 後衛-4 7 3 対戦表 第1 1回戦 前衛-1 - 後衛-2 対 後衛-4 - 前衛-2 2回戦 後衛-1 - 前衛-3 対 後衛-3 - 前衛-2 3回戦 前衛-3 - 後衛-4 対 後衛-3 - 前衛-1 4回戦 後衛-2 - 前衛-3 対 後衛-1 - 前衛-2 5回戦 前衛-1 - 後衛-4 対 後衛-2 - 前衛-2
しかしながら本当に有難う御座います。 数式もほとんどできず、マクロなんてとんでもありませんが 頑張ってみます。 また報告させて下さい。でも、また聞いてしまうかも知れません（すいません） maki
＞現在は、氏名欄を、前衛01、前衛02、後衛01、後衛02、後衛03 ＞と直接入力した場合、何箇所か、組合せが逆になる これは、当クラブでは(と云うか、私の性格として)、 ミックス対戦表において、女が先に出てくるかどうか 気にしないのでそんな作りになっています。
前衛(女)が左に出てくる様、暇みて書き換え、アップします。
＞3 ←参加人数を2で割少ないほうを前衛に =ROUNDDOWN(B1/2,0) ここは理解不能です。 前衛・後衛が固定だとすると、あるがままに入力するしかないと思うのですが。 いつも後衛しかやらない人も、前衛が少な過ぎる日は、ずーっと前衛をやると 云うことなんでしょうか？
(半平太) 2011/09/27 11:10
前衛を左に表示する修正
Sub Paring() の下記２行を ＞ Rem 表にして結果を表示 ＞ Call DisplayResult(matchschedule)
下記１３行と置換え
Rem 表にして結果を表示(まず前衛を左にシフト)
Dim MatchSche2
MatchSche2 = matchschedule
Dim QQQ, PPP
For QQQ = 1 To UBound(MatchSche2)
For PPP = 1 To numOfCourts * 4 Step 2
If MatchSche2(QQQ)(PPP + 1) < MatchSche2(QQQ)(PPP) Then
MatchSche2(QQQ)(PPP) = MatchSche2(QQQ)(PPP + 1)
MatchSche2(QQQ)(PPP + 1) = matchschedule(QQQ)(PPP)
End If
Next PPP
Next QQQ
Call DisplayResult(MatchSche2)
(半平太) 2011/09/27 17:15
＞いつも後衛しかやらない人も、前衛が少な過ぎる日は、ずーっと前衛をやると 云うことなんでしょうか？ ↑ はい仰る通りなんです 前衛と後衛に差が出たときには、普段前衛であってもいなければ後衛に 普段後衛であってもいなければ、前衛になります
教えていただきましたコードで
完璧に動作しました
涙が出るほど嬉しいです 上手くいえなくて申し訳ありませんが 何者ですか？ これって勉強とかで出来る範囲なんですか？ 世の中では、ニュートリノが1億分の6秒光より早くなったと 天文学的な数字の話が出ていましたが、、、 自分の中では、全く考えられない作品を 本当にありがとうございました また遊びに来させて頂きます。 (maki 2011/09/27 23:10)
もしかしたら、偶数の場合は、単純に分け、奇数の場合、 少ないほうが前衛になるってことを氏名の所に自動挿入って可能なのですか？ 例えば 8人の場合は、前衛01、前衛02、前衛03、前衛04、後衛01、後衛02、後衛03、後衛04になり 9人の場合は、前衛01、前衛02、前衛03、前衛04、後衛01、後衛02、後衛03、後衛04、後衛05です
(maki 2011/09/27 23:32)
＞もしかしたら、偶数の場合は、単純に分け、奇数の場合、少ないほうが前衛になるってこと
提示したコードを軟式専用にするのは避けたいので、以下の方法を採って下さい。
(1) B4セル =INT(B1/2) ※MIXは手入力が基本 (2) B5セルに YES と入力 ※硬式の場合は何も入れない
<Main> 行 _________A_________ _B_ ___C___ 1 参加人数 11 必須 2 コート数 1 必須 3 回戦数 8 必須 4 前衛または女子(Mix) 5 Option 5 軟式？ YES Option
(3) モジュールシートのDisplayResultプロシージャの下記10行を
＞ With Worksheets(Main)
＞ .Range("B10:C200").ClearContents
＞ .Range("A9:C9").Value = [{"氏名(前衛が先)","背番号","出場数"}]
＞
＞ nameArys = .Range("A10:C200").Value
＞
＞ For NN = 1 To numTotalPlayers '氏名欄を自動補充
＞ If nameArys(NN, 1) = "" Then
＞ nameArys(NN, 1) = Format(NN, "氏名00")
＞ End If
＞ nameArys(NN, 2) = NN
＞ Next NN
下記24行と置換え
With Worksheets(Main)
.Range("B10:C200").ClearContents
.Range("A9:C9").Value = [{"氏名(前衛又は女子が先)","背番号","出場数"}]
nameArys = .Range("A10:C200").Value
Dim NameToReplenish1, NameToReplenish2
NameToReplenish1 = IIf(numOfFemale > 0, IIf(UCase(.Range("B5").Value) = "YES", "前衛", "女子"), "氏名")
NameToReplenish2 = IIf(numOfFemale > 0, IIf(UCase(.Range("B5").Value) = "YES", "後衛", "男子"), "氏名")
For NN = 1 To 191 '氏名欄を自動補充
Select Case Left(nameArys(NN, 1), 2)
Case "", "氏名", "前衛", "後衛", "女子", "男子"
If NN <= numOfFemale Then
nameArys(NN, 1) = Format(NN, NameToReplenish1 & "00")
ElseIf NN <= numTotalPlayers Then
nameArys(NN, 1) = Format(NN - numOfFemale, NameToReplenish2 & "00")
Else
nameArys(NN, 1) = Empty
End If
End Select
If NN <= numTotalPlayers Then
nameArys(NN, 2) = NN
Else
nameArys(NN, 2) = Empty
End If
Next NN
(半平太) 2011/09/28 23:07
完璧です。全く問題なく動作しました 細かい点までご指示を頂き感謝いたします。 条件付書式で色を加えまして。お蔭様で素晴らしいです。 また質問に来るかもしれませんが何卒お願い申し上げます。 本当に感謝です。有難う御座いました。 maki
先日は大変有難う御座いました お陰さまで大助かりです 重ねてお願いしたいことがございましてまいりました。
この乱数で処理しているものを、順番に連続にならないように 組むことって出来ますか？ 初めは1番からでも何番からでもかまいません
何とぞ宜しくお願い致します （maki)
＞この乱数で処理しているものを、順番に連続にならないように
具体的にどんなケースを避けたいのですか？ 「順番に連続」にも色々な解釈ができるんですが・・・
(半平太) 2011/10/05 09:37
具体的には ・できるだけ、違う人とペアを組む ・できるだけ、各メンバの平均試合数を同じにする ・できるだけ、連続して試合の無いようにする ・できるだけ、連続して休まないようにする 勿論、参加者が少ない時には仕方がありません 宜しくお願い致します
(maki) 2011/10/05 20:58
>・できるだけ、違う人とペアを組む >・できるだけ、各メンバの平均試合数を同じにする >・できるだけ、連続して試合の無いようにする >・できるだけ、連続して休まないようにする >勿論、参加者が少ない時には仕方がありません
優先順をどう設定するか、と云う問題がありますが、 全て叶えられれば、結果論として優先順もくそもない事になります。
性能のいいパソコンを使わないと満足な結果を得るのに時間が掛るかも知れません。 まぁ、私の関知するところではないですけど。
細かいパッチを当てるのも面倒ですので、以下のコードで全面的な書き換えを行ってください。
’標準モジュールのコード全面書換用----------------------------
Public Const Main As String = "Main" Public Const Work As String = "Work"
Public numTotalPlayers Public numOfCourts As Long Public lastRound As Long Public numOfFemale As Long Public maxPlayersOnCourt As Long Public absoluteBestScore As Double Sub Pairing()
Dim wsMain As Worksheet
Dim MatchArranger As MatchArranger Dim players() As Player
Dim matchschedule As Variant
Dim NN As Long, MM As Long, KK As Long Dim SS As Long, TT As Long
With Worksheets(Main)
If .Range("B1").Value < 4 Or _
.Range("B2").Value < 0 Or _
.Range("B2").Value < 1 Then
Exit Sub
End If
End With
Application.ScreenUpdating = False
With Worksheets(Main)
.Range("D10:AZ200").ClearContents
numTotalPlayers = .Range("B1").Value
numOfCourts = .Range("B2").Value
With WorksheetFunction
numOfCourts = .Min(numOfCourts, Int(numTotalPlayers / 4))
End With
lastRound = .Range("B3").Value
numOfFemale = .Range("B4").Value
maxPlayersOnCourt = numOfCourts * 4
absoluteBestScore = absBestScore() '最適解のスコア算出
End With
Set MatchArranger = New MatchArranger
ReDim players(1 To numTotalPlayers)
For NN = 1 To numTotalPlayers 'インスタンス生成
Set players(NN) = New Player
Next NN
Rem MatchArrangerにPlayersを渡して、対戦表を受け取る
matchschedule = MatchArranger.makeDraw(players)
Rem 表にして結果を表示(まず前衛を左にシフト)
Call DisplayResult(matchschedule)
Application.ScreenUpdating = True
End Sub
Sub DisplayResult(ByVal matchschedule)
Dim NN As Long, RR As Long, CC As Long, SS As Long
Dim pairFore As Long
Dim PairBack As Long
Dim plDecke As Long
Dim nameArys As Variant
Dim 対戦表Deck()
Dim 対戦表Name()
Dim 同ペアdisp()
Dim 出番disp()
Dim inputItem
With Worksheets(Main)
.Range("B10:C200").ClearContents
If UCase(.Range("B5").Value) = "YES" Then
.Range("A9").Value = "氏名(前衛が先)"
Else
.Range("A9").Value = "氏名(女子が先)"
End If
.Range("B9:C9").Value = [{"背番号","出場数"}]
nameArys = .Range("A10:C200").Value
Dim NameToReplenish1, NameToReplenish2
NameToReplenish1 = IIf(numOfFemale > 0, IIf(UCase(.Range("B5").Value) = "YES", "前衛", "女子"), "氏名")
NameToReplenish2 = IIf(numOfFemale > 0, IIf(UCase(.Range("B5").Value) = "YES", "後衛", "男子"), "氏名")
For NN = 1 To 191 '氏名欄を自動補充
Select Case Left(nameArys(NN, 1), 2)
Case "", "氏名", "前衛", "後衛", "女子", "男子"
If NN <= numOfFemale Then
nameArys(NN, 1) = Format(NN, NameToReplenish1 & "00")
ElseIf NN <= numTotalPlayers Then
nameArys(NN, 1) = Format(NN - numOfFemale, NameToReplenish2 & "00")
Else
nameArys(NN, 1) = Empty
End If
End Select
If NN <= numTotalPlayers Then
nameArys(NN, 2) = NN
Else
nameArys(NN, 2) = Empty
End If
Next NN
ReDim 対戦表Deck(lastRound, maxPlayersOnCourt * 2)
ReDim 対戦表Name(lastRound, maxPlayersOnCourt * 2)
ReDim 出番表disp(lastRound, numTotalPlayers)
ReDim 同ペアdisp(numTotalPlayers, numTotalPlayers)
Rem タイトル
対戦表Deck(0, 0) = "対戦表"
対戦表Name(0, 0) = "対戦表"
出番表disp(0, 0) = "出番表"
同ペアdisp(0, 0) = "同ペア"
For NN = 1 To numOfCourts
対戦表Deck(0, NN * 8 - 4) = Format(NN, "第0")
対戦表Name(0, NN * 8 - 4) = Format(NN, "第0")
Next NN
For NN = 1 To numTotalPlayers
出番表disp(0, NN) = nameArys(NN, 1)
同ペアdisp(0, NN) = nameArys(NN, 1)
同ペアdisp(NN, 0) = nameArys(NN, 1)
Next NN
For NN = 1 To lastRound
出番表disp(NN, 0) = Format(NN, "0回戦")
Next NN
Rem 本体
For RR = 1 To lastRound
For CC = 1 To maxPlayersOnCourt
対戦表Deck(RR, CC * 2 - 1) = matchschedule(RR)(CC)
対戦表Name(RR, CC * 2 - 1) = nameArys(matchschedule(RR)(CC), 1)
plDecke = matchschedule(RR)(CC)
出番表disp(RR, plDecke) = 出番表disp(RR, plDecke) + 1
Next CC
For CC = 0 To maxPlayersOnCourt
If CC = 0 Then
inputItem = Format(RR, "0回戦")
Else
Select Case CC Mod 4
Case 0: inputItem = ""
Case 1: inputItem = "-"
Case 2: inputItem = "対"
Case 3: inputItem = "-"
End Select
End If
対戦表Deck(RR, CC * 2) = inputItem
対戦表Name(RR, CC * 2) = inputItem
Next CC
For CC = 1 To maxPlayersOnCourt Step 2
pairFore = matchschedule(RR)(CC)
PairBack = matchschedule(RR)(CC + 1)
同ペアdisp(pairFore, PairBack) = 同ペアdisp(pairFore, PairBack) + 1
同ペアdisp(PairBack, pairFore) = 同ペアdisp(PairBack, pairFore) + 1
nameArys(pairFore, 3) = nameArys(pairFore, 3) + 1
nameArys(PairBack, 3) = nameArys(PairBack, 3) + 1
Next CC
Next RR
Rem 出力および整形
With .Range("D9")
.Resize(200, 200).ClearContents
.Resize(200, 200).Offset(, 1).HorizontalAlignment = xlCenter
.Resize(lastRound + 1, maxPlayersOnCourt * 2 + 1).Value = 対戦表Deck
With .Offset(lastRound + 2, 0)
.Resize(lastRound + 1, maxPlayersOnCourt * 2 + 1).Value = 対戦表Name
End With
With .Offset(0, maxPlayersOnCourt * 2 + 1)
.Resize(lastRound + 1, numTotalPlayers + 1).Value = 出番表disp
End With
With .Offset(lastRound + 2, maxPlayersOnCourt * 2 + 1)
.Resize(numTotalPlayers + 1, numTotalPlayers + 1).Value = 同ペアdisp
End With
End With
.Range("A10:C200").Value = nameArys
.Columns("A:AZ").AutoFit
End With
End Sub
Function absBestScore() As Double
Dim sc1 As Double
Dim sc2 As Double
Dim sc3 As Double
Dim sc4 As Double
sc1 = maxPlayersOnCourt * lastRound
If numOfFemale < 1 Then
sc2 = numTotalPlayers * (numTotalPlayers - 1)
Else
sc2 = numOfFemale * (numTotalPlayers - numOfFemale) * 2
End If
sc3 = sc1 Mod sc2
sc4 = Int(sc1 / sc2)
absBestScore = (sc2 - sc3) * sc4 ^ 2 + sc3 * (sc4 + 1) ^ 2
End Function
'MatchArrangerクラスのコード全面書き換え用------------------------------------
Public Sub refreshPlayersRec(ByRef players)
Dim NN As Long
For NN = 1 To numTotalPlayers
Call players(NN).setInitValue(NN, IIf(NN <= numOfFemale, 1, 2))
Next NN
End Sub
Public Function makeDraw(ByRef players)
Const worstPoint As Double = 999999999# Dim wsf As WorksheetFunction Dim trialNo As Long Dim roundNo As Long
Dim NN As Long Dim MM As Long Dim KK As Long
Dim ownOrgckAry() Dim oneRoundPairing()
Dim bestScoreSofar As Double Dim resultScore As Double
Dim Wrec As Variant Dim isBestResult As Boolean
Set wsf = WorksheetFunction
ReDim oneRoundPairing(1 To lastRound)
ReDim ownOrgckAry(1 To numTotalPlayers, 1 To 2)
bestScoreSofar = worstPoint
For trialNo = 1 To 200 '最適解が見つかるまで200案作る
refreshPlayersRec (players) '背番号と性別のみセット
For roundNo = 1 To lastRound 'ラウンド順に案を作成
Rem 選出考慮データUpdate
For NN = 1 To numTotalPlayers
ownOrgckAry(NN, 1) = players(NN).numPlayed _
+ players(NN).roundPlayedLast * 0.01
ownOrgckAry(NN, 2) = players(NN).Decke
Next NN
oneRoundPairing(roundNo) = pairingForOneRound(players, ownOrgckAry) '一案作成
'ワンラウンド分の結果をPlayersのペア履歴に反映
For KK = 1 To maxPlayersOnCourt Step 2
players(oneRoundPairing(roundNo)(KK)).updatePairingRec oneRoundPairing(roundNo)(KK + 1), roundNo
players(oneRoundPairing(roundNo)(KK + 1)).updatePairingRec oneRoundPairing(roundNo)(KK), roundNo
Next KK
Next roundNo
Wrec = assessFactors(players) '他のプレーヤーと何回組んだか調査
resultScore = wsf.SumProduct(Wrec, Wrec) '出来具合を数値化
If absoluteBestScore = resultScore Then
makeDraw = oneRoundPairing
isBestResult = True
Exit For
ElseIf resultScore < bestScoreSofar Then
bestScoreSofar = resultScore
makeDraw = oneRoundPairing
End If
Next trialNo
If isBestResult = False Then
MsgBox "最適解に達しませんでした。再トライすることをお勧めします"
End If
End Function
Private Function pairingForOneRound(ByRef players, ByVal aryToChoose) Dim MM As Long
Dim maxSamePartner As Long Dim onePair() As Long '
ReDim onePair(1 To maxPlayersOnCourt) As Long
For MM = 1 To maxPlayersOnCourt Step 2
'出場回数で昇順並べ替え
aryToChoose = sortByTimesOfPlay(players, aryToChoose)
'ペア記録Update後、次のペア作成に備える
If aryToChoose(1, 2) < aryToChoose(2, 2) Then
onePair(MM) = aryToChoose(1, 2)
onePair(MM + 1) = aryToChoose(2, 2)
Else
onePair(MM) = aryToChoose(2, 2)
onePair(MM + 1) = aryToChoose(1, 2)
End If
aryToChoose(1, 1) = Empty '成立ペアは次回のソート対象外とする
aryToChoose(2, 1) = Empty
Next MM
pairingForOneRound = onePair
End Function Private Function sortByTimesOfPlay(ByRef players, ByRef ckary) Dim lastLiveRow As Long Dim cel As Range Dim playedWith As Variant
With Sheets(Work)
.Range("A1:F1000").ClearContents
With .Range("A1:C" & UBound(ckary))
.Columns(1).Resize(, 2).Value = ckary
.Columns(3).Formula = "=rand()"
.Columns(3).Value = .Columns(3).Value
.Columns(4).Formula = "=IF(B1>" & Main & "!$B$4,2,1)" '2=男性
.Columns(4).Value = .Columns(4).Value
End With
Rem 出場回数 > 最新出場ラウンド目順 にソート
.Range("A1:F1000").Sort Key1:=.Range("A1"), Order1:=xlAscending, _
Key2:=.Range("C1"), Order2:=xlAscending, Header:=xlNo
lastLiveRow = .Range("A1000").End(xlUp).Row
If lastLiveRow = 1 Then
MsgBox "improper Players'Data. abort to process"
End
End If
Rem 1行目のプレーヤが2行目以下のプレーヤと何度組んだかをチェックして再ソート
playedWith = players(.Range("B1").Value).recordsOfPlayedWith
For Each cel In .Range("B2:B" & lastLiveRow)
cel.Offset(, 3).Value = Application.Index(playedWith, cel.Value)
Next
.Range("A2:E" & lastLiveRow).Sort _
Key1:=.Range("D2"), Order1:=IIf(.Range("D1").Value = 1, xlDescending, xlAscending), _
Key2:=.Range("A2"), Order3:=xlAscending, _
Key3:=.Range("E2"), Order3:=xlAscending, Header:=xlNo
sortByTimesOfPlay = .Range("A1:B" & .Range("A1000").End(xlUp).Row).Value
End With
End Function
Private Property Get assessFactors(ByRef players) Dim NN As Long Dim MM As Long Dim aryToAssess() As Long
ReDim aryToAssess(1 To numTotalPlayers, 1 To numTotalPlayers)
For NN = 1 To numTotalPlayers
For MM = 1 To numTotalPlayers
aryToAssess(NN, MM) = players(NN).timesPlayedwith(MM)
Next MM
Next NN
assessFactors = aryToAssess
End Property
’Playerクラスのコード全面書き換え用------------------------------------
Private ownDecke As Long Private ownSex As Long Private ownNumPlayed As Long Private ownRecordsOfPlayedWith() As Long Private ownRoundPlayedLast As Long
Public Sub setInitValue(ByVal playerDecke As Long, ByVal playerSex As Long)
ownDecke = playerDecke
ownSex = playerSex
ownNumPlayed = 0
ReDim ownRecordsOfPlayedWith(1 To numTotalPlayers)
ReDim ownRecordsOfPlayedAgainst(1 To numTotalPlayers)
End Sub
Public Sub updatePairingRec(ByVal pairDecke As Long, ByVal roundNo As Long)
ownNumPlayed = ownNumPlayed + 1
ownRecordsOfPlayedWith(pairDecke) = ownRecordsOfPlayedWith(pairDecke) + 1
ownRoundPlayedLast = roundNo
End Sub
Public Property Get Decke()
Decke = ownDecke
End Property
Public Property Get sex()
sex = ownSex
End Property
Public Property Get numPlayed()
numPlayed = ownNumPlayed
End Property
Public Property Get roundPlayedLast()
roundPlayedLast = ownRoundPlayedLast
End Property
Public Property Get timesPlayedwith(ByVal pairDecke As Long) As Long
timesPlayedwith = ownRecordsOfPlayedWith(pairDecke)
End Property
Public Property Get recordsOfPlayedWith()
recordsOfPlayedWith = ownRecordsOfPlayedWith
End Property
(半平太) 2011/10/06 00:13
御礼が遅くなり大変申し訳ありません モンスターコード本当に有難う御座います 毎回 ＞MsgBox "最適解に達しませんでした。再トライすることをお勧めします" は現れますが全く問題ありません 読み取ることは不可能ですが。 少しづつ勉強していきたいと思います 本当に感謝でございます。有難う御座いました。 (maki) 2011/10/07 0:29
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.