[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マッチング会での組み合わせの自動化（参加者側の希望あり）について』（KP）
時間割制のビジネスマッチング会の商談希望に対する組み合わせを自動化できないか考えております。 マッチング会当日の流れとしてましては、 （１）受注企業が商談したい発注企業を指定 （２）発注企業が固定のブースを持っており、事前に主催者が組み合わせた時間割で、受注企業が時間入替制で発注企業ブースを回って商談する。
例） 時間割 1時間目：13:00-14:00 2時間目：14:00-15:00 3時間目：15:00-16:00
受注企業(J1-J3の3社社） J1社：H1,H2,H3と商談希望 J2社：H2,H3と商談希望 J3社：H1,H3と商談希望
発注企業（H1-H3の3社）
下記スケジュールにて主催者が時間割りを組む 左から1時間目,2時間目,3時間目 H1社：J1,J3 H2社：J2,J1 H3社：J3,J2,J1
受注企業側の希望する商談希望を最大限叶えるよう（商談数を最大化できるよう）手動で時間割を組んでいます。 実際は、受注企業側も発注企業側も数が多く（数十社程度）、かつ時間割も多いため、 手作業で組むと1日は平気でかかります。
上記例も、手作業で組んでおりますので、最適でない可能性があります。
また、もし可能であれば、発注企業側の間が空く時間を少なく（例えば、発注企業が1時間目と3時間目 に予定が入っていたとすると、1時間目と2時間目に入れられないか検討する）ことも考えたいですが、 ここまでやると複雑になってしまいますので、まずは手作業の組み合わせを自動化できればと考えております。
私なりに色々探してみたのですが、情報が見つからず、もしご助言・ご指導を頂けるようでしたら、 お願いいたします。初心者ではやはり難しいでしょうか。
何卒、よろしくお願い申し上げます。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
基本的なことは分かりましたが、実データがないと考えにくです。
過去の平均的と思われるケースの実績データ(受注・発注・組合せ）を提示できないですか？ (企業名は架空）
※無理にとは言いません、こちらも出来る自信がある訳じゃないので。 ただ、それがあれば回答者も増えるし、理解の行き違いも極小化できます。
（半平太） 2020/06/22(月) 14:23
スケジュール割当は、日付指定しなくて良いのですか？ 1日だけ？ 会場準備も大変なので、普通は数日開催しそうに思うのですが。
過去に、マンションの工事希望日を元に自動配分する質問があり、質問者が考える側の苦労を考えず、ころころ要望を重ねてきてうんざりしましたが、考え方やコードの参考になるかと思います。 これを参考に、まずはinputとoutputをどういうシートレイアウトにするか、考えてみてください。
[[20191130210527]]
（???） 2020/06/22(月) 14:40
半平太様、???様
ありがとうございます。ご指摘の通りかと思います。 承知いたしました。少々お時間頂戴できればと存じます。
マンションの事例も可能な範囲で理解しておきたいので、申し訳ございません、数日かかるかもしれません・・・
スケジュール割り当ては、1日だけで大丈夫です。
そうですね、初心者だからこそ丸投げは良くないですよね。注意します。
まずは、マンション工事希望日の案件を読み込ませて頂き、並行して実績データをご提示できる 形で作成させて頂きます。 類似の事例すら見つけられなかったので、参考事例を頂けただけでもとてもありがたいです。
（KP） 2020/06/22(月) 15:37
'Sheet1からSheet2に展開＆作表
'Sheet1のA1セル=J1社,B1セル=H1社,C1セル=H2社,D1セル=H3社
'Sheet1の下行に続けて記載する(A2セル=J2社, ・・・・）
Dim c As Range, r As Range, ctr As Long
Sheets("Sheet2").Cells.Clear
For Each c In Sheets("Sheet1").Range("B:D").SpecialCells(2)
Set r = Sheets("Sheet2").Range("A:A").Find(c.Value, , , xlWhole)
If r Is Nothing Then
If WorksheetFunction.CountA(Sheets("Sheet2").Range("A:A")) = 0 Then
Set r = Sheets("Sheet2").Range("A1")
Else
Set r = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
End If
r.Value = c.Value
If r.EntireRow.Find(c.EntireRow.Cells(1), , , xlWhole) Is Nothing Then
Sheets("Sheet2").Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value = c.EntireRow.Cells(1)
End If
Next c
ctr = 0
Do
If ctr > 10000 Then MsgBox "試行回数上限オーバー": Exit Do
For Each c In Sheets("Sheet2").Range("A:A").SpecialCells(2)
rn (c.Row)
Next c
If Not ck Then Exit Do
Loop
End Sub
Sub rn(rw)
Dim x As Long, y1 As Integer, y2 As Integer, a As String
x = WorksheetFunction.CountA(Sheets("Sheet2").Rows(rw))
y1 = Int(Rnd * (x - 1)) + 2
y2 = Int(Rnd * (x - 1)) + 2
a = Sheets("Sheet2").Cells(rw, y2).Value
Sheets("Sheet2").Cells(rw, y2).Value = Sheets("Sheet2").Cells(rw, y1).Value
Sheets("Sheet2").Cells(rw, y1).Value = a
End Sub
Function ck() As Boolean
Dim c As Range
For Each c In Sheets("Sheet2").Range("A1").CurrentRegion.SpecialCells(2)
If WorksheetFunction.CountIf(c.EntireColumn, c.Value) > 1 Then ck = True: Exit Function
Next c
End Function
（mm） 2020/06/22(月) 15:56
Dim c As Range
'For Each c In Sheets("Sheet2").Range("A1").CurrentRegion.SpecialCells(2)
For Each c In Sheets("Sheet2").Range("B:D").SpecialCells(2) '3時間目までならこちらでOK
If WorksheetFunction.CountIf(c.EntireColumn, c.Value) > 1 Then ck = True: Exit Function
Next c
End Function
（mm） 2020/06/22(月) 16:15
お忙しいところありがとうございます。心より感謝申し上げます。
内容理解できるよう読み込ませて頂きますので、
少々お時間頂戴できればと存じます。（理解が遅く申し訳ございません・・・
（KP） 2020/06/23(火) 17:05
コードを作成頂き、ありがとうございます。
大変お手数ですが、いくつか（いくつも？）分からない部分がありましたので、
ご教示賜れればと存じます。
また、半平太様から頂いたマンションの事例について、分からないなりに読んでみましたが、
少々レベルが高すぎて、理解するまでに月単位でかかりそうですので、申し訳ございません、
一旦後回しとさせてください。
認識が合っているかのいるかのご確認と、分からなかった部分が混在しておりますが、
上から順に記載させて頂きます。
［１］
For Each c In Sheets("Sheet1").Range("B:D").SpecialCells(2)
から
Next c
までの部分は、
Sheet1のB～D列（発注企業名[H1～H3社]）に値の入っている全てのセル１つづ（ｃ）について、
(1)Sheet2のA列に同じ発注企業名がなく、Sheet2のA列が空なら、rの位置はSheet2のA1セル
(2)Sheet2のA列に同じ発注企業名がなく、Sheet2のA列が空でなければ、rの位置はSheet2のA列の末尾
(3)Sheet2のA列に同じ発注企業名があった場合は、rの位置はSheet2A列のcと完全一致で見つかったセル
(1)～(3)の後、r（Sheet2のA列内：最終的には発注企業名[H1～H3]の全てが入る）の位置に、cの値を代入する
だと考えておりますが、理解は正しいでしょうか。
また、(3)につきまして、同じ企業が複数回HITした場合は上書き（＝何もしない）という認識でよろしいでしょうか。
［２］
If r.EntireRow.Find(c.EntireRow.Cells(1), , , xlWhole) Is Nothing Then
Sheets("Sheet2").Cells(r.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value = c.EntireRow.Cells(1)
End If
についてですが、ここが肝のような気がしているのですが、申し訳ございません、理解が追い付いておりません。
rのある行全体の全ての値に対しcの一つ右の列全体を検索し、一致するものが無ければSheets2のrのある行の右端に
cの値を代入する？ でしょうか。
今の時間帯に発注企業に他の予定が入っていなければ、次の時間帯に発注企業を入れる？（入れても良い？）
というイメージかと思っているのですが、少し違う気もしています。
［３］
Do
If ctr > 10000 Then MsgBox "試行回数上限オーバー": Exit Do
For Each c In Sheets("Sheet2").Range("A:A").SpecialCells(2)
rn (c.Row)
Next c
If Not ck Then Exit Do
Loop
End Sub
Sub rn(rw)
Dim x As Long, y1 As Integer, y2 As Integer, a As String
x = WorksheetFunction.CountA(Sheets("Sheet2").Rows(rw))
y1 = Int(Rnd * (x - 1)) + 2
y2 = Int(Rnd * (x - 1)) + 2
a = Sheets("Sheet2").Cells(rw, y2).Value
Sheets("Sheet2").Cells(rw, y2).Value = Sheets("Sheet2").Cells(rw, y1).Value
Sheets("Sheet2").Cells(rw, y1).Value = a
End Sub
の部分ですが、乱数を使って条件を変えて？、試行を繰り返し、10000まで行ったら諦める？イメージで
考えておりますが、少し理解が違う気がしています。乱数をどう使っているのかも分かりません。
さらに［２］に加えて［３］でもループがなぜ必要か、ctrがどこでカウントアップしているのか、など
理解できておりません・・・。
恐らく、基本的なところが分かっていないように思えます。
乱数については、
y1 = Int(Rnd * (x - 1)) + 2
y2 = Int(Rnd * (x - 1)) + 2
について、多分ここが分かっていないのが原因かとも思っております。
［４］
Function ck() As Boolean
Dim c As Range
For Each c In Sheets("Sheet2").Range("B:D").SpecialCells(2) '3時間目までならこちらでOK
If WorksheetFunction.CountIf(c.EntireColumn, c.Value) > 1 Then ck = True: Exit Function
Next c
End Function
についてですが、
If WorksheetFunction.CountIf(c.EntireColumn, c.Value) > 1
の目的が分かりません。
cの入っている列からcの値をカウントし、１より大きかった場合？でしょうか。
また、4時間目、5時間目と増やしていく場合は、単純に
Range("B:D")
のB:Dの範囲を、B:E、B:Fに広げていけばよろしいでしょうか。
［５］
最初の条件
J1社：H1,H2,H3 J2社：H2,H3 J3社：H1,H3
から、
J1社 H1社 H3社 H2社 J2社 H2社 ［H3←削除] J3社 H1社 H3社
と1件削除して試してみましたが、処理が返ってこなくなりました。
単純に条件が減る分には、処理が返ってこなくなることはないとイメージしていたのですが、
別の理由があるのでしょうか。
［６］［５］と関係しますが、発注企業に対し、時間割数を超えた希望数があった場合は、
物理的に不可能になると思いますが、 それ以外に不可能となるパターンはありますでしょうか。
事前にどこかでチェックして、無限ループを回避するようにできればと考えております。
お忙しいところお手数をおかけし申し訳ございません。
何卒、ご教示賜れればと存じます。
（KP） 2020/06/24(水) 13:02
＞半平太様から頂いたマンションの事例について、
私は何も言ってないですよ。
失礼ながら、そんなもの読んで質問者さんのレベルで分かると思ってないです。 同種の質問かどうか判断するのも難しい。
と言うか、この種の質問は、一つ一つが個別特有な問題と思っています。 なので、実データ(と同等のデータ）を提示して貰ったら、考え易くなるとは言いました。
（半平太） 2020/06/24(水) 13:17
大変失礼いたしました。私の勘違いでした。
ご指摘の通りでして、２～３時間読み込んでみましたが、全く歯が立ちませんでした・・・。
実データにつきましては、申し訳ございません、もう少々お時間ください。
かなりぐちゃぐちゃですので、基本的には最初のイメージ
H1社：J1,J3 H2社：J2,J1 H3社：J3,J2,J1
に直して整理しようかと考えております。
（KP） 2020/06/24(水) 16:47
＞ H1社：J1,J3 ＞ H2社：J2,J1 ＞ H3社：J3,J2,J1 ＞に直して整理しようかと考えております。
私との関係では、そんなことをしないで欲しい。また行き違いが起きます。 すると、 「説明不足ですみません。実は○○がありまして、その対策ではダメです」 と言う展開になるのがオチです。
実績(と同等）のデータで、どう実際に組み合わせたのか、 それを示して頂くのが間違いが少ないです （それでも行き違いが起きないとは言えないですけどね。）
とは言え、mmさんが実コードを提示されているので、まず、それで出来るのかやってみてください。 こちらが参戦するかどうかはその帰趨で決まります。しばらく、私のことは忘れてください。
mmさんのは当初の質問内容だけ作っているので、疑問の余地がないと思うんですけどねぇ。 まぁ、私は他人の回答はロクに見ないので詳しくは分からないですけど。
（半平太） 2020/06/24(水) 17:16
ご連絡ありがとうございます。
そうですね、ご指摘のとおり確かにその可能性は非常に高いと思います。
>とは言え、mmさんが実コードを提示されているので、まず、それで出来るのかやってみてください。
承知いたしました。
mm様のコードをもう少し読み込んだり、動かしたりして勉強させて頂きたいと思います。
（KP） 2020/06/25(木) 09:52
都合の良い時間帯の複数希望考慮は不要のようなので、マンション例よりだいぶシンプルに考えられますね。 考え方として真似するのは、元のデータから一旦J社-H社の1対1を1行とした表に変換し、これを1行ずつ処理していく辺りくらい。
要求のあるデータは全部採用すれば良いだけだし、H社ひとつにJ社が最大幾つ希望があるかで時間帯の上限は決まるでしょうから、空きを見つけた順に全部埋めていくだけかと思います。
mmさんの例だと、乱数を使っていたり、同じ時間帯に既に同じJ社があるかどうかを別関数にしていたり、コードが長くなっていて解読が難しいと思うので、別のコード例を書きますね。 元データと出力データはmmさんの想定したレイアウトと同じものとします。 これに加えて、中間作成する表のために、Sheet3 を用意しておいてください。
Sub test()
Const iMax = 3
Dim HS As Object
Dim DIC As Object
Dim wk1 As Worksheet
Dim wk2 As Worksheet
Dim wk3 As Worksheet
Dim ch As String
Dim cj As String
Dim i As Long
Dim j As Long
Dim iR As Long
Set HS = CreateObject("System.Collections.ArrayList")
Set DIC = CreateObject("Scripting.Dictionary")
Set wk1 = Sheets("Sheet1")
Set wk2 = Sheets("Sheet2")
Set wk3 = Sheets("Sheet3")
wk2.Cells.ClearContents
wk3.Cells.ClearContents
For i = 1 To wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row
For j = 2 To wk1.Cells(i, wk1.Columns.Count).End(xlToLeft).Column
ch = wk1.Cells(i, j).Value
If ch <> "" Then
iR = iR + 1
wk3.Cells(iR, "A").Value = wk1.Cells(i, "A").Value
wk3.Cells(iR, "B").Value = ch
If HS.Contains(ch) = False Then
HS.Add ch
End If
End If
Next j
Next i
HS.Sort
For i = 1 To HS.Count
DIC.Add HS(i - 1), i + 1
Next i
wk2.Range("A2").Resize(HS.Count, 1).Value = WorksheetFunction.Transpose(HS.toArray)
For i = 1 To iMax
wk2.Cells(1, i + 1).Value = i & "時間目"
Next i
For i = 1 To iR
cj = wk3.Cells(i, "A").Value
ch = wk3.Cells(i, "B").Value
For j = 2 To iMax + 1
If wk2.Cells(DIC(ch), j).Value = "" Then
If WorksheetFunction.CountIf(wk2.Range(wk2.Cells(1, j), wk2.Cells(HS.Count + 1, j)), cj) = 0 Then
wk2.Cells(DIC(ch), j).Value = cj
Exit For
End If
End If
Next j
Next i
End Sub
（???） 2020/06/25(木) 15:27
こんにちは。
???さんのコードを拝見いたしました。
試しに動かしてみましたら、 例えば、こういう前提のとき、うまくいかないようです。 J1 H1 H2 H3 H4 J2 H1 H2 H3 H4 J3 H1 H2 H3 H4 J4 H1 H4 J5 H1 H4
J5という受注企業のあてはめが1つだけスキップしてしまいます。（※がまずい）
Round1 Round2 Round3 Round4 Round5
H1 J1 J2 J3 J4 J5
H2 J2 J1 J3
H3 J3 J1 J2
H4 J4 J3 J2 J1 ※
やはり自然体で埋めて行っても不都合が起きることはあるようです。
これは、目の子ですが、 ★の部分を変更することでうまくいきそうです。
Round1 Round2 Round3 Round4 Round5
H1 J1 J2 J3 J4 J5
H2 J2 J1 J3
H3 J3 J1 J2
H4 J5★ J3 J2 J1 J4★
さらにラウンドの順番をまるごと変更しても、条件は満たされますから、 以下のようにすると、 発注企業H2は、少しだけ早く帰ることができます。
Round1 Round4 Round2 Round3 Round5
H1 J1 J4 J2 J3 J5
H2 J2 J3 J1
H3 J3 J2 J1
H4 J5 J1 J3 J2 J4
ですから、
(1)やはりなんらかの組み替えのような工夫を入れる必要があるように思います。
(2)「発注企業側の間が空く時間を少なく」という要件は、組み合わせが決まってから、
ラウンドの順番を入れ替えることで完全ではないですが、対応ができるかもしれません。
実は、VBA以外のものでバックトラック方式を使ったコードを書き、 一応結果は出るようになりましたが、力技すぎるのと、 VBAで書く意欲がちょっと湧いてこない、という現状です。 もう少し時間を掛けて見たいと思っています。 （γ） 2020/06/26(金) 07:21
1時間目 2時間目 3時間目 4時間目 5時間目 6時間目 H1社 J1社 J2社 J3社 J4社 J5社 H2社 J2社 J1社 J3社 H3社 J3社 J1社 J2社 H4社 J4社 J3社 J2社 J1社 J5社
ただ、H4の1時間目をJ5とすれば5時間目までで収まる訳で、最適解でないのは確かです。
マンションのときは、希望が集中している日時ほど後回しにするロジックで最適解としていたので、今回の場合も何か考えないと、荒い結果にしかならないようですね。 希望の多いところ（今回だとH1とH4）から先に埋めるようにするのが良いのかな？ 左詰めにしてH社の負担軽減も考えると、後から入れ替え？（空白の少ない列を前に持っていくだけでも効果でるかも）
しかし、ロジックは複雑にしたくないので（解析できなくなりそうだから）、とりあえずは現状のままとしておきます。
（???） 2020/06/26(金) 09:40
最適化しようとすると、見た目より、結構深い…。
（???） 2020/06/26(金) 09:47
（γ） 2020/06/26(金) 10:59
こんにちは！ 下からお邪魔します。。。 乱数は↓ここから拝借して http://www001.upp.so-net.ne.jp/isaku/mt.html
ちょっと書いてみました。 ルールを読み間違えている可能性が大なのと例によってわちきのことですから全くもって見当違いかもしれません。(^^;
要は、、以前の数独の様に重ならなければいいのですね？？？(と勝手に解釈して） 組み合わせは何回か実行して最終的にはご本人がお決めになるということで (仕様です。諦めてください(^^;）
この↓の場合は、
J1 H1 H2 H3 H4 J2 H1 H2 H3 H4 J3 H1 H2 H3 H4 J4 H1 H4 J5 H1 H4
一例としてこんな↓感じになりました。
1時間 2時間 3時間 4時間 5時間 H1 J1 J2 J5 J4 J3 H2 J2 J1 J3 H3 J3 J2 J1 H4 J5 J3 J1 J2 J4
あってますぅ？？？？
コードは以前の使いまわしなので見直せばもう少しスマートになるかもしれません。。。 あとは頑張ってください。。。。(おっいぃぃぃ）
Option Explicit ' ＶＢＡによるメルセンヌツイスタ ' システムを起動してからの時間をミリ秒単位で返す ' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx Private Declare Function GetTickCount Lib "kernel32" () As Long ' メルセンヌツイスタのパラメータ(ダイナミッククリエーターの結果) Private Const MTN = 644, MTM = 322, MTA = 12, MTB = 7, MTC = 15, MTD = 18 Private Const MXA = &H70C20000, UMK = &H78000000, LMK = &H7FFFFFF Private Const MKB = &H73736B80, MKC = &H6ED28000 ' 補助的な定数の宣言 Private Const MTL = MTN - MTM, MTK = MTN - 1, MTJ = MTL - 1, MTP = MTN - 2 Private Const PWA = 2 ^ MTA, PWB = 2 ^ MTB, PWC = 2 ^ MTC, PWD = 2 ^ MTD Private Const KB = MKB \ PWB, KC = MKC \ PWC Private Const P32 = 2# ^ 32, P31 = 2 ^ 31, P22 = 2# ^ 22, P9 = 2 ^ 9 Private Const M53 = 2# ^ -53, M32 = 2# ^ -32, M30 = 2# ^ -30 ' 乱数の状態 Private mt(0 To MTK), mti As Long ' 初期化の補助関数 Private Function Ri(ByRef r As Double, ByVal i As Long) As Long Dim s As Variant Dim shft As Double Dim a As Long If r >= P31 Then a = r - P32 Else a = r a = a Xor Int(r * M30) If a < 0 Then r = a + P32 Else r = a s = 1812433253 * CDec(r) + i: r = s - CDec(Int(s * M32)) * P32 If r >= P31 Then Ri = r - P31 Else Ri = r End Function ' s を種にして乱数を初期化する Public Sub InitMt(ByVal s As Long) Dim r As Double mt(0) = s And &H7FFFFFFF If s < 0 Then r = P32 + s Else r = s For mti = 1 To MTK: mt(mti) = Ri(r, mti): Next mti mti = MTN End Sub ' 31 ビットの整数乱数 Public Function NextMt() As Long Dim y, k As Long If mti = 0 Then InitMt (1) If mti = MTN Then mti = 0 For k = 0 To MTJ y = (mt(k) And UMK) Or (mt(k + 1) And LMK) mt(k) = mt(k + MTM) Xor (y \ 2) Xor (-(y And 1) And MXA) Next k For k = MTL To MTP y = (mt(k) And UMK) Or (mt(k + 1) And LMK) mt(k) = mt(k - MTL) Xor (y \ 2) Xor (-(y And 1) And MXA) Next k y = (mt(MTK) And UMK) Or (mt(0) And LMK) mt(MTK) = mt(MTM - 1) Xor (y \ 2) Xor (-(y And 1) And MXA) End If y = mt(mti): mti = mti + 1 y = y Xor (y \ PWA): y = y Xor ((y And KB) * PWB) y = y Xor ((y And KC) * PWC): y = y Xor (y \ PWD): NextMt = y End Function ' 0 以上 1 未満の乱数を返す Public Function NextUnifMt() As Double Dim x As Long x = NextMt \ P9: NextUnifMt = (NextMt * P22 + x) * M53 End Function ' 時間を種にして乱数を初期化する Public Sub RandomizeMt() InitMt (GetTickCount()) End Sub Sub てすと() Dim MyDic As Object Dim v As Variant Dim y As Variant Dim yy() As Variant Dim Tempyy As Variant Dim x As Variant Dim z As Variant Dim i As Long Dim j As Long Dim k As Long ReDim y(0) v = Sheets("Sheet1").Range("A1").CurrentRegion.Value Set MyDic = CreateObject("Scripting.Dictionary") For i = LBound(v, 1) To UBound(v, 1) For j = LBound(v, 2) + 1 To UBound(v, 2) If Not IsEmpty(v(i, j)) Then If Not MyDic.Exists(v(i, j)) Then ReDim x(0) x(0) = v(i, 1) MyDic(v(i, j)) = x k = k + 1 Else x = MyDic(v(i, j)) ReDim Preserve x(UBound(x) + 1) z = Application.Match(v(i, 1), x, 0) If IsError(z) Then x(UBound(x)) = v(i, 1) MyDic(v(i, j)) = x k = k + 1 Else MsgBox v(i, j) & " に" & v(i, 1) & " が重複しています。" Exit Sub End If End If End If Next Next y = MyDic.Keys ReDim Preserve yy(UBound(y) + 1) For i = LBound(y) To UBound(y) yy(i + 1) = y(i) Next yy = Application.Transpose(yy) ReDim Preserve yy(LBound(yy, 1) To UBound(yy, 1), LBound(v, 1) To UBound(v, 1) + 1) For j = LBound(yy, 2) + 1 To UBound(yy, 2) yy(1, j) = j - 1 & "時間" Next Tempyy = yy RandomizeMt 探索 MyDic, Tempyy, yy, k With Sheets("Sheet2") .Cells.Clear .Range("A1").Resize(UBound(yy, 1), UBound(yy, 2)).Value = yy End With Set MyDic = Nothing Erase v, y, yy, x, Tempyy End Sub Private Sub MyFScs(ByRef x As Variant) Dim y As Variant Dim i As Long Dim j As Long Dim MyScs As Object Set MyScs = CreateObject("System.Collections.SortedList") ReDim y(LBound(x, 1) To UBound(x, 1)) For i = LBound(x, 1) To UBound(x, 1) MyScs(NextUnifMt()) = i Next For i = 0 To MyScs.Count - 1 y(i) = x(MyScs.GetByIndex(i)) Next x = y Set MyScs = Nothing Erase y End Sub Sub 探索(ByVal MyDic As Object, ByVal Tempyy As Variant, ByRef yy As Variant, ByVal k As Long) Dim x As Variant Dim q As Variant Dim z As Variant Dim i As Long Dim j As Long Dim r As Long Dim n As Long n = 0 yy = Tempyy For i = LBound(yy, 1) + 1 To UBound(yy, 1) x = MyDic(yy(i, 1)) MyFScs x For j = LBound(yy, 2) + 1 To UBound(yy, 2) For r = LBound(x) To UBound(x) If Not IsEmpty(x(r)) Then If IsEmpty(yy(i, j)) Then q = Application.Match(x(r), Application.Index(yy, i, 0), 0) z = Application.Match(x(r), Application.Index(yy, 0, j), 0) If IsError(q) * IsError(z) Then yy(i, j) = x(r) x(r) = Empty n = n + 1 Exit For End If End If End If If Application.CountA(x) = 0 Then Exit For Next If Application.CountA(x) = 0 Then Exit For Next Next If k <> n Then 探索 MyDic, Tempyy, yy, k End Sub
Loopの可読性が悪いので再帰にしました。 その他も少し見直しました。2020/06/27 07:43 （SoulMan） 2020/06/26(金) 17:07
ついでですが、僭越ながら、mmさんのロジックを、私のロジックと比較して解説したいと思います。
mmさんのロジックは、まず元の表から、H社をA列にして、対応するJ社を、時間無視して左詰めに並べたところから始まります。
次に、横方向にランダムで2か所のセルを入れ替えます。これを行数分繰り返します。（rnプロシジャ）
並べ終わったら、今度は同じ時間帯に同じJ社が重複してないかチェックします。（ckプロシジャ）
全列チェックし、重複がなければ終了ですが、1箇所でも重複があれば、また並べ替えからやり直します。
変数ctrを加算していないのは、コーディング忘れでしょう。無限に探し続けてしまうので、rnプロシジャを呼んだ後にでも、ctr = ctr + 1 と追加すれば良いでしょう。
特徴としては、正常に終われば必ず左詰めの最適解になりますが、ランダムなので時間がかかる事と、答えが得られない事があります。
また、問題点として、左詰め最適解を前提としているために、絶対に1時間ずらす必要があるケースだと、答えが得られません。
試行回数を超えたなら、今度は左詰めを諦めて、最大列までで入れ替えるように処理追加すれば改善できると思います。
こんな元データの場合ですね。
J1社 H1社 H2社 H3社
J2社 H1社
J3社 H1社
（SoulManさんのロジックは、これでも問題無し）
私のロジックは全く逆で、重ならない時間を見つけた順に、どんどん右に伸ばしていくだけです。
だからどんなデータでも必ず答えを出しますが、最適化を全く考えていません。
外部オブジェクトを使っている部分が判りにくいと思いますが、全体のロジックは単純なので、理解しやすいと思います。
（???） 2020/06/26(金) 18:06
ぱっぱぁ～っと書いたので見直しました。 まだあるかもしれません。
>より自然な乱数生成ロジックを持ってきたのでしょうか。
すみません。多分、、暇なんですね(^^; 基本的に使いまわしですから。。。。 常連様はご承知だと思いますが、、私の乱数定番なのですね。。 コピペするだけですから(笑)
それでは、またよろしくお願いいたします。m(__)m （SoulMan） 2020/06/26(金) 18:44
余談です：
メルセンヌ・ツイスタ (Mersenne twister、通称MT) は、 松本眞氏と西村拓士氏の開発になる疑似乱数で、 2^19937 -1 (4.3*10^6001程度）と長周期であり、性質も良いところに特徴。 多くの言語で、このMT(ないしその改良版であるSFMT）が標準乱数として採用されています。
参考(Wikipedia) https://ja.wikipedia.org/wiki/%E3%83%A1%E3%83%AB%E3%82%BB%E3%83%B3%E3%83%8C%E3%83%BB%E3%83%84%E3%82%A4%E3%82%B9%E3%82%BF
ExcelVBAのRnd関数の周期は約1677万しかありません。 (なお、ワークシートのRAND関数の周期は少し長くて 2,147,483,648) その周期に問題があると考える場合は、MTなどの使用を検討することに なります。
参考URL： 松本眞さんの開発に関する話は、検索するとペーパーや動画もあり、とても面白いですね。 http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/mt.html
疑似乱数に関しては、和田維作さんのページ「良い乱数・悪い乱数」が有益。 http://www001.upp.so-net.ne.jp/isaku/rand.html
引用されたコードは、↓こちらのものですね。 http://www001.upp.so-net.ne.jp/isaku/mt.html
また、MTのアドインはこちらにあります。こちらも使い易いです。 http://www.ntrand.com/jp/ （鳥居さんのニューメリカルテクノロジーズ社製のもの。無料です。）
# 松本さんは他大学に転出していたが、また広島大に戻られたと聞いた。 # 広島大が奥さんの実家の近くということもあって # そこがとても気に入っているという話を読んだことがある。
（γ） 2020/06/26(金) 22:09
お忙しいところありがとうございます。
ご返信遅くなり申し訳ございません。
昨日まで???様のコードを読み込ませて頂いておりまして、
一部少し自信がありませんが、多分、理解できたと思います。
私の方でも色々なデータで試してみたいと思います。
SoulMan様のコードも、（レベルが高くかなり自信がないですが）読み込ませて頂き、
色々なデータで試したみたいと思います。ありがとうございます。
乱数部分はまず理解できない自ががありますので「Sub てすと()」から先を
中心に勉強させて頂きます。
mmさんの例だと、乱数を使っていたり、同じ時間帯に既に同じJ社があるかどうかを別関数
ああ、そういうことだったんですね。全く理解できておりませんでした。
視点を変えてもう一度読み直してみます。
mmさんのロジックを、私のロジックと比較して解説したいと思います。
これは本当に助かりました。
私の知識不足により完全ではありませんが、大分理解が進みそうです。
最終的には、時間はかかると思いますが、
私でもできそうなレベルの機能（時間割より多くの希望が入っている場合などで
メッセージを出して事前に止めるようなもの）を加えてみたいと思います。
理解が遅く、返信も遅く、大変心苦しく考えておりますが、
何卒、よろしくお願い申し上げます。
心より感謝申し上げます。
（KP） 2020/06/27(土) 08:08
SoulManさんの労作拝見しました。
処理の中で気になったのは（失礼）、 シャッフル処理のなかで、その都度 RandomizeMt を実行している点です。 これは、メインの中で「一回だけ実行すればよい」のではないかと思います。 長周期なので弊害は少ないかと思いますが、理屈から言えば、 複数回のRandomizeMt のせいで、同じ乱数列が開始してしまう可能性は ゼロではないと思います。 （これは、既定のRnd関数でよくされる指摘です。それと同じかと思います）
質問者さんには、企業数の概算を教えてもらうとよいと思います。 数十では幅がある感じです。2,30なのか、7,80 かによって 計算負荷も変わってきます。 たぶん、そう重い処理ではないので、対応は可能かと思いますが。
また、 | 受注企業が商談したい発注企業を指定 とのことですが、その比率ですね。それもあると有効な情報ではないでしょうか。
なお、 | 発注企業側の間が空く時間を少なく（例えば、発注企業が1時間目と3時間目 | に予定が入っていたとすると、1時間目と2時間目に入れられないか検討する） | ことも考えたいですが、 この部分は、重要度にもよりますが、 複数個の案を作成し、この中から、 例えば、「最初の時間帯部分の空き状況」と「最後の時間帯部分の空き状況」の合計を 最大にするものを選択すれば、実質的にカバーできるのではないかと思います。
（γ） 2020/06/27(土) 08:53
おはようございます。 朝の散歩に行ってました。 >私でもできそうなレベルの機能（時間割より多くの希望が入っている場合などで >メッセージを出して事前に止めるようなもの）を加えてみたいと思います。
私も気になっていましたので中止するコードを追記しました。
>複数回のRandomizeMt のせいで、同じ乱数列が開始してしまう可能性は >ゼロではないと思います。
ですよねぇ(^^; 外に出しました。 ありがとうございます。m(__)m
では、、病院に行ってきます。。。。もうおじいちゃんなので。。。 また何かありましたらよろしくお願い致します。。。。 （SoulMan） 2020/06/27(土) 10:03
重ね重ねありがとうございます。m(__)m
勉強させて頂きます。
お気をつけて行ってらっしゃいませ。
（KP） 2020/06/27(土) 10:51
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.