Results of 1 - 1 of about 7 for ダブルス (0.001 sec.)
- [[20110925230142]]
- #score: 11578
- @digest: 3f13f1cd4fcdddb753b3c3149d08dbea
- @id: 56061
- @mdate: 2011-10-06T15:29:02Z
- @size: 44273
- @type: text/plain
- #keywords: 前衛 (386306), 後衛 (319112), numtotalplayers (314110), players (298343), namearys (296348), maxplayersoncourt (208674), lastround (202995), 衛- (199282), 回戦 (172228), 同ペ (149655), matchschedule (148174), roundno (143198), numoffemale (137188), 戦表 (134626), arytochoose (130826), oneroundpairing (130826), matcharranger (119950), pairfore (114558), pairback (114558), 表na (104976), 表de (104976), inputitem (102184), 対戦 (95810), numofcourts (94485), ownrecordsofplayedwith (88570), アdi (85857), onepair (82313), 軟式 (77615), 表di (75818), pairdecke (73808), ownorgckary (73808), resultscore (72681)
- 『軟式テニスの組合せ表』（maki）
こんばんわ 何時も勉強させて頂いております。宜しくお願い致します。 軟式テニスの組合せ表を考えています 軟式については、前衛と後衛とポジンションが分かれており 硬式のダブルスの表には沢山いいものがありましたが 使うことは出来ませんでした。(硬式は、前衛・後衛の分けが無く人数でランダムに可能のため) そこで、以下の条件で組合せ表を作成したいのですが ご教授いただければ幸いです。宜しくお願い致します。 ・できるだけ、違う人とペアを組む ・できるだけ、各メンバの平均試合数を同じにする ・できるだけ、連続して休まないようにする ・使用するコートは1面で実施する 人数は、日々出席者がまちまちです 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） ---- 1.Sheet1のシート名を「Main」、Sheet2のシート名を「Work」としてください。 2.標準モジュールを以下の手順で1つ挿入してください。 (ALT+F11としてVBE表示)→VBEメニュー[挿入]→[標準モジュール] 後記コードをコピペしてください。 3.クラスモジュールを以下の手順で二つ挿入してください。 プロパティウィンドウからクラス名をそれぞれ「MatchArranger」「Player」として下さい。 それぞれに、後記コードをコピペしてください。 4.Mainシートに所要計数を入力してください。 <Main>今回の例 行 ______A______ _B_ ___C___ 1 参加人数 9 必須 ←「前衛」+「後衛」 2 コート数 1 必須 3 回戦数 8 必須 ← 使用時間と参加人数から適当に割り出して(でも必ず)入れてください。 4 前衛(軟式時) 5 Option 5.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) ---- > 3.クラスモジュールを以下の手順で二つ挿入してください。 > プロパティウィンドウからクラス名をそれぞれ「MatchArranger」「Player」として下さい。 以下の手順というのがなかった・・・・m(__)m <訂正後> 3.クラスモジュールを以下の手順で二つ挿入してください。 (ALT+F11としてVBE表示)→VBEメニュー[挿入]→[クラスモジュール] プロパティウィンドウからクラス名をそれぞれ「MatchArranger」「Player」として下さい。 (半平太) 2011/09/26 22:33 ---- 半平太様有難うございます ちょうど入力しているところでした ＞ 3.クラスモジュールを以下の手順で二つ挿入してください。 (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() の下記2行を ＞ Rem 表にして結果を表示 ＞ Call DisplayResult(matchschedule) 下記13行と置換え 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201109/20110925230142.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97057 documents and 608292 words.
訪問者：