[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『オートメーションエラーについて』（KP）
いつもお世話になっております。
『マッチング会での組み合わせの自動化（参加者側の希望あり）について』（KP）
http://www.excel.studio-kazu.jp/kw/20200622134052.html
でお世話になったものです。
色々試した見たのですが、自力では難しそうですので、ご助力お願いできればと存じます。
大分時間が空いてしまいましたが、頂戴したマクロを少しづつ読んだり試したりして勉強していたのですが、困ったことが発生してしまいました。
SoulManさんに作って頂いたマクロについて、
Set MyScs = CreateObject("System.Collections.SortedList")
のところで「オートメーションエラー」が発生してしまいました。
自宅環境では問題なく動作しており、職場環境でエラーが出ていたため、調べたところ、（多分ですが）.net frameworkがインストールされていないことが原因だと思われます。ただ、セキュリティの関係から、職場環境にインストールはできそうにありません。
また、関係するか分かりませんが、
「コンパイルエラー：
このプロジェクトのコードは、64ビット システムで使用するために更新する必要があります。Declareステートメントの確認及び更新を行い、次にDeclareステートメントにPtrSafe属性を設定してください。」
のエラーが出たため、2行目に「PtrSafe」を付けて
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
にしています。
色々試してみた結果を下記に記載します。
（１）
Set MyScs = reateObject("System.Collections.Generic.SortedList")
ですと、「ActiveXコンポーネントはオブジェクトを作成できません。」が出ます。
（２）
Dim MyScs As New mscorlib.SortedList
mscorlibを参照設定して上記を試してみたのですが、やはりオートメーションエラーが出てしまいます。（自宅環境だとこれでも動きます。）
（３）浅知恵ですが、
Set MyScs = CreateObject("Scripting.Dictionary")
で行けるかと思い試してみたところ、動くには動くのですが、結果がランダム表示できず固定になってしまいました。（教えて頂いたマクロをそのまま自宅で試すと、実行のたびに結果がちゃんとランダムに切り替わります。）
これも浅知恵ですが、ソートすればうまくいくかもと考え、別のところから配列をソート数する処理を追加してみたのですが、やはり結果がランダムに動きません。
最終的に試したソースが下記です。
Option Explicit
' ＶＢＡによるメルセンヌツイスタ
' システムを起動してからの時間をミリ秒単位で返す
' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx
Private Declare PtrSafe 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("Scripting.Dictionary") 'SortedListが動かないため修正
Call DicSort(MyScs) '駄目もとでソート
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.Items()(i)) 'ScriptingDictionaryに合わせて修正
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
'https://qiita.com/daik/items/682743bb8bcd8b5f0689より引用 ' Dictionaryを参照引数にし、これをソートする破壊的プロシージャ。 Sub DicSort(ByRef dic As Object) Dim i As Long, j As Long, dicSize As Long, key As Variant Dim varTmp() As String
dicSize = dic.Count
ReDim varTmp(dicSize + 1, 2)
' Dictionaryが空か、サイズが1以下であればソート不要
If dic Is Nothing Or dicSize < 2 Then
Exit Sub
End If
' Dictionaryから二元配列に転写
i = 0
For Each key In dic
varTmp(i, 0) = key
varTmp(i, 1) = dic(key)
i = i + 1
Next
'クイックソート Call QuickSort(varTmp, 0, dicSize - 1)
dic.RemoveAll
For i = 0 To dicSize - 1
dic(varTmp(i, 0)) = varTmp(i, 1)
Next
End Sub
' String型で2列の二次元配列を受け取り、これの1列目でクイックソートす る（ほんとはCompareメソッドを渡すAdapterパターンで書きたいところ、VBAのオブジェクト指向厳しい感じで妥協）
Private Sub QuickSort(ByRef targetVar() As String, ByVal min As Long,
ByVal max As Long)
Dim i, j As Long
Dim tmp As String
If min < max Then
i = min
j = max
pivot = strMed3(targetVar(i, 0), targetVar(Int((i + j) / 2), 0), targetVar(j, 0))
Do
Do While StrComp(targetVar(i, 0), pivot) < 0
i = i + 1
Loop
Do While StrComp(pivot, targetVar(j, 0)) < 0
j = j - 1
Loop
If i >= j Then Exit Do
tmp = targetVar(i, 0)
targetVar(i, 0) = targetVar(j, 0)
targetVar(j, 0) = tmp
tmp = targetVar(i, 1)
targetVar(i, 1) = targetVar(j, 1)
targetVar(j, 1) = tmp
i = i + 1
j = j - 1
Loop
Call QuickSort(targetVar, min, i - 1)
Call QuickSort(targetVar, j + 1, max)
End If
End Sub
'' String型のx, y, z を辞書順比較し二番目のものを返す
Private Function strMed3(ByVal x As String, ByVal y As String, ByVal z As String)
If StrComp(x, y) < 0 Then
If StrComp(y, z) < 0 Then
strMed3 = y
ElseIf StrComp(z, x) < 0 Then
strMed3 = x
Else
strMed3 = z
End If
Else
If StrComp(z, y) < 0 Then
strMed3 = y
ElseIf StrComp(x, z) < 0 Then
strMed3 = x
Else
strMed3 = z
End If
End If
End Function
SortedListへの理解不足、全体のロジックに対する理解不足など、原因は沢山あるかと思います。お忙しいところ恐縮ですが、ご助言頂けると幸いです。
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
Set MyScs = CreateObject("Scripting.Dictionary")
にした上で、
ReDim y(LBound(x, 1) To UBound(x, 1))
For i = LBound(x, 1) To UBound(x, 1)
MyScs(Rnd) = i 'MyScs(NextUnifMt()) = iから変更
Next
です。
こちらも動くには動くのですが、結果がランダムに切り替わりません・・・
見当違いのことをやっている自覚はあるのですが・・・
（KP） 2020/09/07(月) 16:16
とりあえず参照宣言部分だけ。
DLL の参照は VBA のバージョン（EXCEL の2007以前と2010以降）、EXCEL の32ビット版、64ビット版で 異なりますので、下記のように条件判定すれば、どの版でもエラーにならないようになります。 これはよく使うSleep などでも同様です。
#If VBA7 Then #If Win64 Then Declare PtrSafe Function GetTickCount64 Lib "kernel32" () As LongLong #Else Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long #End If #Else Declare Function GetTickCount Lib "kernel32" () As Long #End If
SortedList に関しても使用できない環境があるので、単純にキーで並べ替えるのであれば Dictionary をベースに似た機能を作成する方が早いかもしれません。 この辺りは後程時間が取れたら、コメントします。 （QS） 2020/09/07(月) 18:03
ありがとうございますm(__)m
今自宅のためテストできませんが、明日出社次第会社の環境で試してみます。
SortedListに関して、自分なりに調べてみたのですが、お恥ずかしながら全体のロジックへ
の理解不足で、どう影響しているか分かっておりません・・・。
これで関係なかったりしたら非常に申し訳なく・・・。
（KP） 2020/09/07(月) 20:49
こんばんは！ どこかで見たことがあるコードだと思ったら。。。 64BitのSortedListを使わないコードです。。。 どうぞ
Option Explicit ' ＶＢＡによるメルセンヌツイスタ ' システムを起動してからの時間をミリ秒単位で返す ' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx 'Private Declare Function GetTickCount Lib "kernel32" () As Long Declare PtrSafe Function GetTickCount64 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 (GetTickCount64()) End Sub Sub てすと2() 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 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 Private Sub MyFScs(ByRef x As Variant) Dim y As Variant Dim i As Long Dim j As Long ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2) For i = LBound(x, 1) To UBound(x, 1) y(i + 1, 1) = x(i) y(i + 1, 2) = Round(NextUnifMt(), 5) Next QuickSort y, 2, LBound(y, 1), UBound(y, 1) For i = LBound(x, 1) To UBound(x, 1) x(i) = y(i + 1, 1) Next Erase y End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As Variant MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) > MySMid i = i + 1 Loop Do While MySAry(j, MySKey) < MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub すみません。参考にしたコードが違っていましたねm(__)m （SoulMan） 2020/09/07(月) 21:54
早速出社して試してみました。
Declare Function GetTickCount Lib "kernel32" () As Long
が赤字になっていましたが、条件分岐で回避しているため、全く問題なく動作しました。
こういう方法もあるんですね。ありがとうございます。
SoulMan様
前回に引き続き、ありがとうございます。
職場環境でも全く問題なく動作しました。きちんとランダムです。
何をやっても解決できなかったので、とてもうれしいです。
その過程で素人なりに色々調べましたので、勉強になりました。
後は、ロジックの理解に努めるとともに、色々なデータで試してみようかと思います。
取り急ぎ、御礼とご報告までで失礼させていただきます。
（KP） 2020/09/08(火) 08:47
今回はたまたまでしょうけれど、あるいは修正対応したのかもしれませんが、
InitMt (GetTickCount64())
の部分も
#If VBA7 And Win64 Then
InitMt (GetTickCount64())
#Else
InitMt (GetTickCount())
#End If
としないと、32 ビット環境で動かない気もしますが、これは Randomize と Rnd じゃダメなのかな？
アイデアだけですけれど、Dictionary のItemに Dictionary 使う方法もありそうですね。 それだと Exists 判定と Add、Count で処理が楽にできそうです。 （QS） 2020/09/08(火) 09:09
コメントありがとうございます。
ご説明不足と理解不足で申し訳ございません。
あまり詳しくなく恐縮ですが、環境は64ビットのようです。
ただ、Windows Updateが管理者によりWSUSで制御されているようで、例えば、.NetFrameworkなど
が入っていません。自宅環境との一番の差はここになると考えております。
（WSUSという言葉自体を今回知りましたので、正しいかは微妙です・・・）
また、書き方が合っているか自信がありませんが、
Public Sub RandomizeMt() Randomize InitMt (Rnd) End Sub
でも問題なく動きました。
ただ、同じ実データで繰り返し実行してみましたが、元のマクロにくらべると偏りがある（同じ結果が連続で出やすい）ような気もします。素人の感想ですので、勘違いの可能性が高いですが・・・
後は、実データで沢山テストして整合性をチェックしてみたいと思います。
ちなみに、検索すると結構色々出てきましたので、私のような初心者で同じ状況になっている方はそこそこいらっしゃるのでは、と考えております。
>アイデアだけですけれど、Dictionary のItemに Dictionary 使う方法もありそうですね。 >それだと Exists 判定と Add、Count で処理が楽にできそうです。
ありがとうございます。
勉強になりそうですので、こちらも考えてみたいと思います。
（KP） 2020/09/08(火) 12:23
どなたかが指摘していたかもしれませんが、 Randomaize は処理の最初で１回。であとはRndのみのコールです。
確かにRnd の周期は1600万程度ですが、それでも通常の乱数として使用するには十分な気がします。 （QS） 2020/09/08(火) 13:04
ありがとうございます。
>確かにRnd の周期は1600万程度ですが、それでも通常の乱数として使用するには十分な気がします。
やはり私の先入観による勘違いだったようです。大変失礼いたしました。m(__)m
（KP） 2020/09/08(火) 16:41
いつもお世話になっております。
本件、お忙しいところありがとうございます。
追加でご質問させていただいてもよろしいでしょうか。
『マッチング会での組み合わせの自動化（参加者側の希望あり）について』（KP）
http://www.excel.studio-kazu.jp/kw/20200622134052.html
において、
また、もし可能であれば、発注企業側の間が空く時間を少なく（例えば、発注企業が1時間目と 3時間目に予定が入っていたとすると、1時間目と2時間目に入れられないか検討する）ことも 考えたいですが、 ここまでやると複雑になってしまいますので、
の部分は組み込まれておりますでしょうか。
組み込んでほしい、というわけではなく、仮に組み込んでいるとしたら、どのあたりを読めば
いいのかな、と思った次第でございます。
試行回数を増やして気に入った組み合わせが出るまでリトライすれば済むことですので・・・
また、基礎の基礎だけはようやく分かってきた気がしたので、頂いたマクロに再チャレンジ
してみたのですが、やはりまだ難しいようです。（用語だけ分かっても全体が理解できてお
りません。）
大変お手数ですが、
「Sub 探索」と 「Private Sub MyFScs」のざっくりとした位置づけ・考え方をご指導いただいても
よろしいでしょうか。（簡単で構いません）
完全に理解するのは当分先になると思いますが、概略でも理解できたらな、と考えております。
むしろ「数独」とやらを先に勉強したほうが良いのでしょうか・・・
何卒、よろしくお願い申し上げます。
※どちらのスレッドに書くか悩みましたが、こちらに書かせていただきました。
ルール違反になっているようでしたら、大変申し訳ございません。
お忙しいところ誠に恐れ入りますが、何卒、よろしくお願い申し上げます。
（KP） 2020/09/12(土) 09:16
おはようございます。 他人が書いたコードを理解するのは難しいと思います。 私が最初のころよくやっていたのは変数名を自分流に置き換えて自分のコードに書き直すことをよくやっていました。 某サロンのapp**さんのコードなんかは何度も何度も書き直してましたね。 なのでおこがましい話ですが、今でも私のコードにはその名残が所々にあります。 私流に簡単なコメントを付けてみましたので良かったら参考にしてみてください。
では、、では、、、また。。。
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
'二次元配列を準備
ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2)
'引数配列 x の下限から上限までループ
For i = LBound(x, 1) To UBound(x, 1)
'二次元の要素1に x(i) を代入
y(i + 1, 1) = x(i)
'二次元の要素2に 乱数 を代入
y(i + 1, 2) = Round(NextUnifMt(), 5)
Next
'要素2の乱数を基準に並び替え
QuickSort y, 2, LBound(y, 1), UBound(y, 1)
'x(i)に要素1を代入
For i = LBound(x, 1) To UBound(x, 1)
x(i) = y(i + 1, 1)
Next
Erase y
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
'配列yyの一次元上限までループ
For i = LBound(yy, 1) + 1 To UBound(yy, 1)
'対象の配列を取得
x = MyDic(yy(i, 1))
'サブルーチンで並び替え
MyFScs x
'yyの二次元上限までループ
For j = LBound(yy, 2) + 1 To UBound(yy, 2)
'xの上限までループ
For r = LBound(x) To UBound(x)
'x(r)が空白ではなくて
If Not IsEmpty(x(r)) Then
'代入するyyが空白だったら
If IsEmpty(yy(i, j)) Then
'yyの一次元方向にチェック
q = Application.Match(x(r), Application.Index(yy, i, 0), 0)
'yyの二次元方向にチェック
z = Application.Match(x(r), Application.Index(yy, 0, j), 0)
'どちらも未入力ならyyに代入してxを消去カウンターを+1
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
（SoulMan） 2020/09/12(土) 10:26
お忙しいところ度々ありがとうございます。m(__)m
私が最初のころよくやっていたのは変数名を自分流に置き換えて自分のコードに書き直すことをよくやっていました。
やはりものすごく努力されているのですね。見習いたいです。でも、確かに勉強になりそうです。
私流に簡単なコメントを付けてみましたので良かったら参考にしてみてください。
重ね重ねありがとうございます。
まずは、今回ご教示いただいた内容を何とか咀嚼してみます。
mmさんのと、???さんのマクロは（多分、何とか）理解できましたので、SoulManさんのマクロもいつかは理解できると信じて頑張ってみます。
また、わからない点出てまいりましたら、ご教示給われれば幸いでございます。
最初に比べると少しマシになった気でおりますが、配列が難しいですね・・・。
ちなみに、「数独」はまだ理解できていません。こちらも頑張ってみます。
（KP） 2020/09/12(土) 11:40
いくつかメモしておきます。
(1)もう研究が進んでいると思いますが、SoulManさんのコードは概要以下のとおりかと思います。
各発注企業について、それとの面談を希望する受注希望企業群を保持し、 それを MyFScs でランダムシャッフリングし、 これをその順番に、各時間毎に、配置していきます。
その際、同一の時間に受注希望企業が重ならないようにチェックしながら 配置する、という作業を実行しているわけです。
一回で上手くいくことは稀で、予定した組みあわせをすべて配置できるまで、 何度も繰り返すわけです。
(2) その試行を再帰という形で実行していますが、場合によっては解が求まらない場合もありえます。 例えば、 J1 H1 H2 H3 H5 J2 H2 H4 J3 H1 H3 H5 J4 H1 H2 H3 H4 H5 といったケースで実行すると、スタックオーバーフローを起こします。 これは前提が想定していないケースだからですが、これに類したことが起きないとも 限りませんので、一定の回数上限を設けたほうがよいかもしれません。
(3) | また、もし可能であれば、発注企業側の間が空く時間を少なく（例えば、発注企業が1時間目と | 3時間目に予定が入っていたとすると、1時間目と2時間目に入れられないか検討する）ことも | えたいですが、 ここまでやると複雑になってしまいますので、 | の部分は組み込まれておりますでしょうか。 | 組み込んでほしい、というわけではなく、仮に組み込んでいるとしたら、どのあたりを読めば | いいのかな、と思った次第でございます。 これは、考慮されていないと思います。 もちろん、当初は解を得ることが目的でしたから。
こうしたことを考慮するのであれば、 ロジックで追っていくよりも、 複数の解を調べて、そのうち適切なものを選ぶという方式のほうが適切でしょう。
前回のスレッドで書きましたが、例えば、こんな方式が考えられます。 各発注企業ごとに、面談と面談の間の「待ち時間」を計算し、 それらの合計が最小となるものを最適解とすればよいわけです。 （一時間目から空き時間のものや、最後に空き時間が連続するものは、 「待ち時間」には入れません。遅れて来たり、早帰りすればよいからです。）
試しに、ExcelVBAではありませんが、別の処理系を使って、 発注企業20社、受注希望社18社の例（詳細は末尾に書きました）で調べて見ました。 一つの解を選るのに上限100回の繰り返しを行い、さらにそれを100回繰り返しました。 100回の繰り返しで解が得られたものは、34回でした。
そして、その34回について、上記の「待ち時間」を求めると、こんな分布でした。
「待ち時間」 頻度
23 1
24 0
25 0
26 1
27 0
28 1
29 2
30 2
31 5
32 5
33 2
34 2
35 7
36 1
37 0
38 4
39 1
------------------
計 34
結構ばらけるものですね。
この場合、待ち期間が最小の23の回を最適解にすればよいと思われます。
ロジックが幾分違うので、もっとよい解があるかもしれませんが。
（ちなみに、総計算時間は 0.9秒くらいでした。)
---------------------- 参考：試算例の前提 J1 H1 H2 H4 H6 H8 H9 H11 H12 H13 H14 H16 H17 H19 H20 J2 H3 H4 H5 H6 H8 H9 H10 H11 H12 H14 H16 H18 H19 H20 J3 H1 H3 H4 H5 H6 H7 H8 H9 H10 H11 H12 H13 H14 H15 H19 H20 J4 H1 H4 H5 H7 H8 H9 H11 H12 H13 H16 H17 H18 H19 J5 H3 H8 H9 H10 H11 H12 H14 H15 H16 H18 H20 J6 H3 H4 H6 H8 H9 H10 H12 H15 H17 H18 H19 J7 H1 H3 H4 H5 H6 H7 H8 H10 H11 H12 H18 H19 H20 J8 H1 H2 H3 H4 H6 H7 H8 H9 H10 H13 H14 H15 H16 H17 H18 H19 J9 H1 H2 H3 H4 H5 H9 H10 H12 H13 H15 H16 H17 H18 H19 H20 J10 H1 H2 H3 H4 H5 H6 H7 H8 H9 H11 H12 H13 H15 H16 H17 H18 H19 H20 J11 H1 H2 H3 H4 H5 H6 H8 H9 H10 H11 H12 H13 H17 H18 H19 H20 J12 H1 H2 H3 H4 H5 H6 H7 H9 H12 H14 H15 H16 H17 H18 H19 H20 J13 H1 H3 H4 H5 H7 H8 H9 H11 H12 H13 H14 H15 H17 H19 H20 J14 H2 H3 H4 H5 H6 H7 H8 H10 H12 H13 H14 H16 H17 H18 H19 J15 H1 H2 H3 H4 H5 H6 H7 H9 H10 H11 H13 H14 H15 H16 H17 H18 H20 J16 H1 H2 H3 H4 H5 H6 H7 H8 H9 H10 H11 H14 H18 H20 J17 H1 H2 H3 H4 H5 H6 H8 H9 H10 H12 H13 H14 H16 H17 H19 J18 H1 H2 H3 H7 H8 H10 H11 H12 H13 H14 H15 H16 H17 H18 H19 （γ） 2020/09/13(日) 22:51
いつもお世話になっております。
ご返信遅くなり申し訳ございません。
詳細なコメントありがとうございます。m(__)m
コードの概要のご説明、本当に助かります。
（まだまだですが）少しづつ分かってきましたので、引き続き読み込んでみたいと思います。
スタックオーバーフローのご指摘もありがとうございます。
おっしゃる通りでした（こちらの環境でも何回か確認できました）ので、試行回数が一定数超えた
段階で止めるようにしました。
変数kを使っていないのにカウントアップされていたのは、その名残なのかな、と勝手に思い
そのまま使わせて頂いております。
詳しいシミュレーションまでして頂き、重ねてお礼申し上げます。
また、前回のスレッドでご返事ができておらず大変失礼いたしました。
考え方は（多分）理解できましたので、どのように実装すればよいか、しばらく考えてみたいと思います。まず間違いなく分からない点が出てくるかと思いますので、その際は改めてご教示をおねがい
できれば幸いでございます。m(__)m
（KP） 2020/09/14(月) 16:55
＞変数kを使っていないのにカウントアップされていたのは、その名残なのかな、と勝手に思い
いやいや、きちんと使われていますよ。
＞'すべて成功していなければ 探索を再帰
＞If k <> n Then 探索 MyDic, Tempyy, yy, k
カウントアップされたn が必要数k に達したかどうか判定しています。
（γ） 2020/09/14(月) 17:10
早速ありがとうございます。
お恥ずかしい限りです・・・
今、データを書き出しながら読み込んでおりますが、かなり理解が怪しいですね・・・
改めて教えを乞う形にさせていただければ幸いです・・・
（KP） 2020/09/14(月) 20:11
乱数生成ロジック部分は、それこそ手に負えませんので、Sub てすと2の解読から
始められればと考えております。
データは
J1：H1,H2,H3 J2：H2,H3 J3：H1,H3 で考えておりますが、
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
の部分ですが、ざっくりSheet1のデータを配列v（2次元配列？）に放り込み、
すべてのv(i,j）（iは行番号、jは列番号？）について、空白でなくかつ辞書（連想配列）MyDicに登録が無ければ、x：受渡し用の1次元配列？、v(i,1）1列目＝J企業？で、辞書にMyDicにJ企業を登録
それ以外だったら、xの領域をUboundで1つ拡張して、拡張部にv(i,1）を入れる？
まとめると、MyDicに重複の無いよう1列目のJ企業を格納する？感じでしょうか。
かなり自信がありません・・・
後ろのほうも相当怪しいですが、まずはここから理解しないと先に進めないような気がしております。
ReDim x(0) 配列の初期化？ x(0) = v(i, 1) ？？？ MyDic(v(i, j)) = x ？？？
の部分や、
z = Application.Match(v(i, 1), x, 0)
のzの位置づけが特に分かっておりません。zって何でしょうか・・・
前回のスレッドで書きましたが、例えば、こんな方式が考えられます。 各発注企業ごとに、面談と面談の間の「待ち時間」を計算し、 それらの合計が最小となるものを最適解とすればよいわけです。 （一時間目から空き時間のものや、最後に空き時間が連続するものは、 「待ち時間」には入れません。遅れて来たり、早帰りすればよいからです。）
ありがとうございます。この方法をを組み込めればと考えております。
最終的には、2時間連続で空きが発生しないようにできればとも考えてお
りますが、まずは元の仕組みを理解していないと話になりませんので、
お忙しいところ何度もお手数をおかけしますが、ご教示のほど、よろしく
お願い申し上げます。
どこかのタイミング連続の空白をカウントして、それまでの結果より小さかったときのみ入れ替える
といった流れが一番単純なのかなと思っておりますが、いかがでしょうか。
複数保持して選ぶ、などですと多分私の頭が追いつきません・・・
お忙しいところ誠に恐れ入りますが、何卒、よろしくお願い申し上げます。
（KP） 2020/09/14(月) 21:44
こんばんは！ SoulMan大研究ですね(^^;) あんまりじっくり見られると穴だらけですからそこそこで願いしますよ
もう私の手は離れている様なので大まかにコメントしますね
>まとめると、MyDicに重複の無いよう1列目のJ企業を格納する？感じでしょうか。
ディクショナリーを使っているので重複を除くことは簡単なので なぜ現状のコードになったのかはその時の私に聞かないとわかりませんが、 私のコードによく使われる Application.Match(v(i, 1), x, 0) は その存在を調べているのですね。 調べるだけなら方法はいくつかあるのですが、まぁ、、俗にいう 癖 ですね。(^^;) それと、、バグをカバーするために追記したのですね。 なので変則的になっている可能性はありますね。
さらに、 ReDim x(0) x(0) = v(i, 1) MyDic(v(i, j)) = x の様に右辺と左辺を = で結ぶ記述も頻繁に出てきますが、これは代入しているのですね。 この様な記述の仕方をなんというのか忘れました。。。すみませんm(__)m
取得して 変化させて 再取得
という流れが多いです。。。これも、、俗にいう癖です。
私はコードを書くとき実は頭の中で取り合えず考えておいてそれを書く 解が違ったら解に沿うように変更を加える みたいな流れが多いです。
以前にもコメントしましたが、変数名をご自身の変数名にすることをお勧めします。 その時の注意点として、置換を使って一度に全部置換するのではなく一つやっては動作確認 問題なく動くことを確認してまた置換 以上を繰り返していくとご自身のコードになります。
わかり難ければ日本語でもいいと思いますよ。 私なんかは、、最大値 とか 探索 とか イケてない日本語が続々出てきます(笑) これも自論ですけど、、コードなんてのは書いた本人でも後から読み返すと？？？？と 思う記述は沢山あるものです。
最終的には、ブレイクポントで止めてローカルウィンドウで変数の中身を確認しながら Debugする これに尽きるのです。
他人のコードをご自身のコードに書き換える
これが、一番の近道かと思います。
では、、では、、、頑張ってください。。。おやすみなさいzzzzzzzzzzzzzzzz （SoulMan） 2020/09/14(月) 22:41
夜分遅くにありがとうございます。m(__)m
こんばんは！ SoulMan大研究ですね(^^;)
そうですね。勉強させていただいております。
以前にもコメントしましたが、変数名をご自身の変数名にすることをお勧めします。
承知いたしました。
自信がないので後にしようと思っていましたが、やってみます。
最終的には、ブレイクポントで止めてローカルウィンドウで変数の中身を確認しながら Debugする
こちらもやってみます。
お恥ずかしながら（昨日のは特に・・・）理解が遅いので、少し時間が空いてしまうかも
しれませんが、改めてご教示いただければ幸いです。
まずは変数の書き換え、並行してDebugで変数の中身を追う、理解ができたら、γさんの
ロジック（空きをできるだけつめる）を考え、最終形（連続の空きを極力排除する）の順で
進められればと考えております。
前途多難ですね・・・
（KP） 2020/09/15(火) 06:04
変数の名前変更や、あちこちにブレークポイントを仕掛けて変数・配列の動きを観察し、
色々分かってきたことと分からないことがあるのですが（これらにつきましては、もう少し
調べてから別途ご質問させてください）、急げば実環境でテスト運用ができそうでしたので、
まずは、γさんのロジックを簡略化して、空きを数えて少ない方を選ぶことだけでもできないか
書いてみたのですが、「スタック領域が不足しています」がでてしまいました。
とりあえず100回探索を繰り返してemptyを数えて、前の値より小さければ、yyを入れ替える
形にしたつもりですが、全然ダメでした・・・
最終的には、H1,H2,H3の時間割りから、連続の空きを減らすことをやりたいのですが・・・
また、遅れて参加、終わったら早帰りのロジックを昨日一日考えてみたのですが、
全然思いつきません・・・。混乱してきてどこが分からないのか分からなくなってきました・・・
お忙しいところ誠に恐れ入りますが、ご教示お願いできればと存じます。
受注企業(J1-J3の3社社） J1社：H1,H2,H3と商談希望 J2社：H2,H3と商談希望 J3社：H1,H3と商談希望
発注企業視点 左から1時間目,2時間目,3時間目 H1社：J1,J3 H2社：J2,J1 H3社：J3,J2,J1 発注企業（H1-H3の3社）※H1,H2,H3視点の連続の空白を極力避ける H1,H2,H3は遅く始まったら遅く来て頂き、早く終わったら帰って頂く（=空白扱いにしない）
試したソースは下記となります。（追加した部分などにはコメントを入れております）
Option Explicit
' ＶＢＡによるメルセンヌツイスタ
' システムを起動してからの時間をミリ秒単位で返す
' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx
'Private Declare Function GetTickCount Lib "kernel32" () As Long
Declare PtrSafe Function GetTickCount64 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 (GetTickCount64())
End Sub
Sub てすと2()
Dim MyDic As Object
Dim v As Variant
Dim y As Variant
Dim yy() As Variant
Dim Tempyy As Variant
Dim yy2() As Variant '追加
Dim x As Variant
Dim z As Variant
Dim i As Long
Dim j As Long
'以下追加 Dim k As Long Dim l As Long Dim m As Variant Dim n As Long Dim o As Long Dim p 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 'コメントアウト
'追加始め ReDim yy2(LBound(yy, 1) To UBound(yy, 1), LBound(yy, 2) To UBound(yy, 2)) '追加 ReDim m(100)
For n = 1 To 100
For k = LBound(yy2, 1) To UBound(yy2, 1)
For l = LBound(yy2, 2) To UBound(yy2, 2)
If IsEmpty(yy2(k, l)) Then
m(n) = m(n) + 1
If m(n + 1) < m(n) Then
yy2(k, l) = yy(k, l)
End If
End If
Next l
Next k
n = n + 1
Tempyy = yy
RandomizeMt
探索 MyDic, Tempyy, yy, k
Next n
'追加終わり
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
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
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2)
For i = LBound(x, 1) To UBound(x, 1)
y(i + 1, 1) = x(i)
y(i + 1, 2) = Round(NextUnifMt(), 5)
Next
QuickSort y, 2, LBound(y, 1), UBound(y, 1)
For i = LBound(x, 1) To UBound(x, 1)
x(i) = y(i + 1, 1)
Next
Erase y
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal
MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As Variant
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
Do
Do While MySAry(i, MySKey) > MySMid
i = i + 1
Loop
Do While MySAry(j, MySKey) < MySMid
j = j - 1
Loop
If i >= j Then Exit Do
For n = MySLBound To MySUBound
MyStmp = MySAry(i, n)
MySAry(i, n) = MySAry(j, n)
MySAry(j, n) = MyStmp
Next
i = i + 1
j = j - 1
Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
（KP） 2020/09/17(木) 11:32
(c)と(d)は簡単な繰り返しで求められます。（空白かどうかの判定を使うだけ。）
探索が成功する毎に上記を計算し、
最小値を更新するとともに、
最小値を実現する組み合わせをVariant変数に保持していけばよいでしょう。
ちなみに、私は、提示されたコードとは別に、
VBAではないプログラミング言語で書いている（自己研鑽のため）ので、
提示されたVBAコードはよく見ていませんし、追記はできません。悪しからず。
頑張って下さいね。
# 書いておいたものをアップしておきます。
（γ） 2020/09/17(木) 11:53
早速のご返答ありがとうございます。とても助かりました。
そうやって考えるんですね。全然思いつきませんでした・・・
落ち着いてもう少し考えてみます。
（KP） 2020/09/17(木) 12:11
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()
''' Randomize
''' InitMt (Rnd)
InitMt (GetTickCount())
' #If VBA7 And Win64 Then ' InitMt (GetTickCount64()) ' #Else ' InitMt (GetTickCount()) ' #End If End Sub
Sub てすと2()
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
Debug.Print k
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
'以下を追加
Dim a As Long Dim b As Long Dim c As Long Dim d As Long Dim l As Long Dim m As Long Dim n As Long Dim yyy As Variant Dim aki As Variant
a = (UBound(yy, 1) - LBound(yy, 1)) * (UBound(yy, 2) - LBound(yy, 2)) b = k ReDim aki(100)
For l = 1 To 100
Tempyy = yy RandomizeMt 探索 MyDic, Tempyy, yy, k
For i = LBound(yy, 1) To UBound(yy, 1)
For j = UBound(yy, 2) To LBound(yy, 2)
If IsEmpty(yy(i, j)) Then
c = c + 1
End If
Exit For
Next j
Next i
For m = LBound(yy, 1) To UBound(yy, 1)
For n = UBound(yy, 2) To LBound(yy, 2) Step -1
If IsEmpty(yy(m, n)) Then
d = d + 1
Else
End If
Exit For
Next n
Next m
aki(l) = a - b - c - d
If aki(l - 1) < aki(l) Then
yy = yy
End If
Next l
'追加ここまで
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
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
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2)
For i = LBound(x, 1) To UBound(x, 1)
y(i + 1, 1) = x(i)
y(i + 1, 2) = Round(NextUnifMt(), 5)
' y(i + 1, 2) = Round(Rnd, 5)
Next
QuickSort y, 2, LBound(y, 1), UBound(y, 1)
For i = LBound(x, 1) To UBound(x, 1)
x(i) = y(i + 1, 1)
Next
Erase y
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal
MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As Variant
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
Do
Do While MySAry(i, MySKey) > MySMid
i = i + 1
Loop
Do While MySAry(j, MySKey) < MySMid
j = j - 1
Loop
If i >= j Then Exit Do
For n = MySLBound To MySUBound
MyStmp = MySAry(i, n)
MySAry(i, n) = MySAry(j, n)
MySAry(j, n) = MyStmp
Next
i = i + 1
j = j - 1
Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
（KP） 2020/09/17(木) 22:12
こんばんは！ 熱心ですねぇ(^^; その待ち時間の考え方自体が今一理解出来ていないのでコードに書けませんが、 取り合えず探索に回数とフラグを乗っけて規程数に達すればループを抜ける様にしてみました。 待ち時間に限らずコードにするときはいきなりコードにするのではなく その仕組みや原理をよく理解されてからコードにすることをお勧め致します。
では、、では、、 または。。。ないよ(^^;
Option Explicit ' ＶＢＡによるメルセンヌツイスタ ' システムを起動してからの時間をミリ秒単位で返す ' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx 'Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare PtrSafe 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 てすと2() 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 Dim kk As Long Dim MyFlg As Boolean 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, kk, MyFlg With Sheets("Sheet2") .Cells.Clear If MyFlg = False Then .Range("A1").Resize(UBound(yy, 1), UBound(yy, 2)).Value = yy Else MsgBox "規定数に達しました。" End If End With Set MyDic = Nothing Erase v, y, yy, x, Tempyy End Sub Sub 探索(ByVal MyDic As Object, ByVal Tempyy As Variant, ByRef yy As Variant, ByVal k As Long, ByRef 回数 As Long, ByRef MyFlg As Boolean) 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 Const 上限 As Long = 10 Dim 空き As Long Dim v As Variant 回数 = 回数 + 1 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 '------------------------------------------------- 空き = 0 For Each v In Application.Index(yy, i, 0) If v = "" Then 空き = 空き + 1 Next MsgBox "空きは " & 空き & " 個です。" '------------------------------------------------- Debug.Print mycounta(Application.Index(yy, i, 0)) Exit For End If End If End If If mycounta(x) = 0 Then Exit For Next If mycounta(x) = 0 Then Exit For Next Next If 回数 > 上限 Then MyFlg = True Exit Sub End If If k <> n Then 探索 MyDic, Tempyy, yy, k, 回数, MyFlg End Sub Private Sub MyFScs(ByRef x As Variant) Dim y As Variant Dim i As Long Dim j As Long ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2) For i = LBound(x, 1) To UBound(x, 1) y(i + 1, 1) = x(i) y(i + 1, 2) = Round(NextUnifMt(), 5) Next QuickSort y, 2, LBound(y, 1), UBound(y, 1) For i = LBound(x, 1) To UBound(x, 1) x(i) = y(i + 1, 1) Next Erase y End Sub Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long) Dim MySMid As Double Dim i As Long, j As Long, n As Long Dim MySLBound As Long, MySUBound As Long Dim MyStmp As Variant MySLBound = LBound(MySAry, 2) MySUBound = UBound(MySAry, 2) MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey) i = MySLeft j = MySRight Do Do While MySAry(i, MySKey) > MySMid i = i + 1 Loop Do While MySAry(j, MySKey) < MySMid j = j - 1 Loop If i >= j Then Exit Do For n = MySLBound To MySUBound MyStmp = MySAry(i, n) MySAry(i, n) = MySAry(j, n) MySAry(j, n) = MyStmp Next i = i + 1 j = j - 1 Loop If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1 If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight End Sub Function mycounta(ByVal v As Variant) As Long Dim x As Variant For Each x In v If x <> "" Then mycounta = mycounta + 1 Next End Function （SoulMan） 2020/09/17(木) 23:14
ありがとうございます。
何度もご迷惑をおかけし申し訳ございませんm(__)m
ご迷惑を承知の上で、あと一つだけ教えてください。
（つまらない質問ばかりで申し訳ございません）
例えば、空きを数えるループ文を作ったとして、どこに設置するのが
よろしいでしょうか。
昨日は、（失敗しましたが）（てすと２）ルーチンに組み込もうとしておりましたが、
（探索）ルーチンに組み込むべきなのでしょうか・・・
何卒、よろしくお願い申し上げます。
（KP） 2020/09/18(金) 11:28
こんにちは！ 何時もは こんばんは！ ですけど、、今日は半日休暇で帰って来ました。(そんな個人情報はええから早よ！回答せんかえ！おっさん！！！すみませんm(__)m)
ところで正直その理論がわかってないのとコードを書いてから久しく経ってますのでどんなコードだったか覚えていません(おおぃぃぃ！！←そんなもんです(^^;） なので適当に応用していただけると助かります。
Excel2007の時は、Application.Counta が使えたと思ったのですがExcel2019では効かないですね(多分。。。） なので For Each で回すのがいいと思います。
γさんのコメントを見るとさほど難しい話ではないようですけど、、理屈というか理論がわからないのでピントがずれている可能性はあります。 考える気になってないというかぁ、わかろうとしていないだけかもしれませんが。。。。
まぁ、、頑張ってください。。。 出来上がったらUpしてくださいね。。。上のコードは直しておきました。
では、、では、、、 （SoulMan） 2020/09/18(金) 13:11
方法は色々あります。例えば自作の関数を作るとか。。。 これなら数えたい時に数えたい配列を放り込むだけで済みます。。。 まぁ、、応用ですけど、、、好みと状況によってCaseByCaseですね
Function mycounta(ByVal v As Variant) As Long
Dim x As Variant
For Each x In v
If x <> "" Then mycounta = mycounta + 1
Next
End Function
（SoulMan） 2020/09/18(金) 13:29
いつもお世話になっております。
ありがとうございます。m(__)m
昨日も、夜遅くにご返答いただきまして重ねて御礼申し上げます。
何とか気力が戻ってきましたのと、幸か不幸か（どちらかというと不幸よりですが）週末特に
予定もありませんので、じっくり考えてみます。
もちろん、出来上がったら必ずUPします。いつになるか分かりませんが・・・。
できるだけ急ぎます・・・。
少しづつ理解が進みまして、ようやくクイックソートが必要な理由が分かりました。
探索部分ももう少しで理解できそうな気がします。奥が深いですね・・・
（KP） 2020/09/18(金) 20:08
一度話を単純化してトライして、それから細かい条件を詰めようと思いまして、「探索」に下記を追加しました。
Dim i2 As Long Dim j2 As Long Dim D As Long
If k = n Then
For i2 = LBound(yy, 1) + 1 To UBound(yy, 1)
For j2 = LBound(yy, 2) + 2 To UBound(yy, 2)
If IsEmpty(yy(i2, j2 - 2)) And IsEmpty(yy(i2, j2 - 1)) And Not IsEmpty(yy(i2, j2)) Then
D = D + 1
Debug.Print D
End If
Next j2
Next i2
aki(k2) = D
End If
k2 = k2 + 1
If aki(k2 - 1) < aki(k2) Then
yy2 = yy
End If
End Sub
想定では、nがkに達して、かつ自分には何か入っていて、左隣が2つ連続でemptyだったら、Dを加算。
配列akiにDを格納し、前のakiより値が小さかったらyy2にyyを代入・・・
（最終的にはyy2をセルに書き出し）
のつもりだったのですが、Dの値が大きすぎるのは後で条件を詰めるとしても、k2もカウントアップしておらず、配列aki(1以降)に値が全く入りません・・・。原因は何でしょうか・・・
さらに、
If aki(k2 - 1) < aki(k2) Then
yy2 = yy
End If
のIf文を抜いてもyy2にも値が入りません。
全ソースは下記となります。きっと物凄く基本的な部分な気もするのですが・・・
お忙しいところ申し訳ございません、ご教示賜れればと存じます。
' ＶＢＡによるメルセンヌツイスタ
' システムを起動してからの時間をミリ秒単位で返す
' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx
'Private Declare Function GetTickCount Lib "kernel32" () As Long
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 てすと2()
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
Dim kk As Long
Dim MyFlg As Boolean
Dim k2 As Long
Dim yy2 As Variant
Dim aki(10)
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, kk, MyFlg, k2, yy2, aki
'探索 MyDic, Tempyy, yy, k, kk, MyFlg
With Sheets("Sheet2")
.Cells.Clear
If MyFlg = False Then
.Range("A1").Resize(UBound(yy, 1), UBound(yy, 2)).Value = yy
Else
MsgBox "規定数に達しました。"
End If
End With
Set MyDic = Nothing
Erase v, y, yy, x, Tempyy
End Sub
'Sub 探索(ByVal MyDic As Object, ByVal Tempyy As Variant, ByRef yy As Variant, ByVal k As Long, ByRef 回数 As Long, ByRef MyFlg As Boolean) Sub 探索(ByVal MyDic As Object, ByVal Tempyy As Variant, ByRef yy As Variant, ByVal k As Long, ByRef 回数 As Long, ByRef MyFlg As Boolean, ByRef k2 As Long, ByRef yy2, ByRef aki) 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
Const 上限 As Long = 10 Dim 空き As Long Dim v As Variant 回数 = 回数 + 1
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
'-------------------------------------------------
空き = 0
For Each v In Application.Index(yy, i, 0)
If v = "" Then 空き = 空き + 1
Next
' MsgBox "空きは " & 空き & " 個です。"
' Debug.Print 空き
'-------------------------------------------------
' Debug.Print mycounta(Application.Index(yy, i, 0))
Exit For
End If
End If
End If
If mycounta(x) = 0 Then Exit For
Next
If mycounta(x) = 0 Then Exit For
Next
Next
If 回数 > 上限 Then
MyFlg = True
Exit Sub
End If
If k <> n Then 探索 MyDic, Tempyy, yy, k, 回数, MyFlg, k2, yy2, aki
'If k <> n Then 探索 MyDic, Tempyy, yy, k, 回数, MyFlg
Dim i2 As Long Dim j2 As Long Dim D As Long
If k = n Then
For i2 = LBound(yy, 1) + 1 To UBound(yy, 1)
For j2 = LBound(yy, 2) + 2 To UBound(yy, 2)
If IsEmpty(yy(i2, j2 - 2)) And IsEmpty(yy(i2, j2 - 1)) And Not IsEmpty(yy(i2, j2)) Then
D = D + 1
Debug.Print D
End If
Next j2
Next i2
aki(k2) = D
End If
k2 = k2 + 1
If aki(k2 - 1) < aki(k2) Then
yy2 = yy
End If
End Sub
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2)
For i = LBound(x, 1) To UBound(x, 1)
y(i + 1, 1) = x(i)
y(i + 1, 2) = Round(NextUnifMt(), 5)
Next
QuickSort y, 2, LBound(y, 1), UBound(y, 1)
For i = LBound(x, 1) To UBound(x, 1)
x(i) = y(i + 1, 1)
Next
Erase y
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal
MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As Variant
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
Do
Do While MySAry(i, MySKey) > MySMid
i = i + 1
Loop
Do While MySAry(j, MySKey) < MySMid
j = j - 1
Loop
If i >= j Then Exit Do
For n = MySLBound To MySUBound
MyStmp = MySAry(i, n)
MySAry(i, n) = MySAry(j, n)
MySAry(j, n) = MyStmp
Next
i = i + 1
j = j - 1
Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
Function mycounta(ByVal v As Variant) As Long
Dim x As Variant
For Each x In v
If x <> "" Then mycounta = mycounta + 1
Next
End Function
（KP） 2020/09/19(土) 15:23
ごく大雑把に言えば、こういう方式になるかと思います。 参考にして下さい。
==== 暫定最小値 を仮に10000などとしておく（初期化）
For k = 1 to 100 ’試行を100回繰り返す
探索
探索に成功したら
そのケースの「評価値」を計算
それが今までの暫定最小値を下回ったら
暫定最小値 = 評価値 '新記録を更新
暫定適正ケース = yy 'その時の結果を保存する
End If
End If
Next
「暫定最小値」や「暫定適正ケース」を採用する
====
まずは、てすと2 のなかで「複数回の試行を繰り返す」にはどうしたらよいか、 というところから始めたらどうでしょうか。 繰り返しにあたっては、 ・どの変数を初期化し、 ・どの変数は初期化せずに前提として継続して使うのか を考える必要があると思います。
（γ） 2020/09/19(土) 16:49
いつもお世話になっております。m(__)m
何度もお手数をおかけし申し訳ございません。ありがとうございます。
教えていただいた方法で再トライしてみます。
連休中に終わると良いのですが・・・
（KP） 2020/09/19(土) 20:05
SoulManさんが （SoulMan） 2020/09/17(木) 23:14の投稿にあるコードに手を入れられていたのを 見逃していました。
余計なことを申し上げたかもしれませんね。失礼しました。
イメージだけでは伝わりにくいかと思い直し、修正案をアップしておきます。 以下は、2020/09/17(木) 23:14の投稿と差があるプロシージャのみです。
Sub てすと2()
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
Dim kk As Long
Dim MyFlg As Boolean
Dim t
t = Timer
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
' ■以下に手を入れました。
Dim trial As Long
Dim 待ち期間 As Long
Dim 暫定最小待ち期間 As Long
Dim 最適yy As Variant
暫定最小待ち期間 = 10000
For trial = 1 To 10 ' ■ 10は勿論、仮置きの回数です。必要に応じて修正してください。
DoEvents
Application.StatusBar = trial
探索 MyDic, Tempyy, yy, k, kk, MyFlg
With Sheets("Sheet2")
.Cells.Clear
If MyFlg = False Then
.Range("A1").Resize(UBound(yy, 1), UBound(yy, 2)).Value = yy '出力不要かも
待ち期間 = 待ち期間計算(yy, k)
Debug.Print 待ち期間; Tab(10); trial
If 待ち期間 < 暫定最小待ち期間 Then
暫定最小待ち期間 = 待ち期間
最適yy = yy
End If
Else
'''MsgBox "規定数に達しました。" 'ここはコメントにしました。
End If
End With
MyFlg = False
kk = 0
Next
'最終結果
Sheets("Sheet2").Range("A1").Resize(UBound(最適yy, 1), UBound(最適yy, 2)).Value = 最適yy
Set MyDic = Nothing
Erase v, y, yy, x, Tempyy
Application.StatusBar = False
Debug.Print Timer - t
End Sub
Function 待ち期間計算(ByVal yy As Variant, ByVal k As Long) As Long
Dim r&, c&, points&
For r = 2 To UBound(yy, 1)
For c = 2 To UBound(yy, 2)
If IsEmpty(yy(r, c)) Then
points = points + 1
Else
Exit For
End If
Next
For c = UBound(yy, 2) To 2 Step -1
If IsEmpty(yy(r, c)) Then
points = points + 1
Else
Exit For
End If
Next
Next
待ち期間計算 = (UBound(yy, 1) - 1) * (UBound(yy, 2) - 1) - k - points
End Function
Sub 探索(ByVal MyDic As Object, ByVal Tempyy As Variant, ByRef yy As Variant, ByVal k As Long, ByRef 回数 As Long, ByRef MyFlg As Boolean)
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
'' Const 上限 As Long = 10 '10回だと解が見つからないことが多かったので。
Const 上限 As Long = 100
Dim 空き As Long
Dim v As Variant
回数 = 回数 + 1
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 mycounta(x) = 0 Then Exit For
Next
If mycounta(x) = 0 Then Exit For
Next
Next
If 回数 > 上限 Then
MyFlg = True
Exit Sub
End If
If k <> n Then 探索 MyDic, Tempyy, yy, k, 回数, MyFlg
End Sub
（γ） 2020/09/20(日) 07:14
ついでに。
(1) 前回のスレッドで以下の質問をしていましたが、回答をもらえますか？
| 質問者さんには、企業数の概算を教えてもらうとよいと思います。 | 数十では幅がある感じです。2,30なのか、7,80 かによって | 計算負荷も変わってきます。 | たぶん、そう重い処理ではないので、対応は可能かと思いますが。 | | また、 | | 受注企業が商談したい発注企業を指定 | とのことですが、その比率ですね。それもあると有効な情報ではないでしょうか。
(2)とりわけ、後半の質問は、以下の話に関係してきます。
| その試行を再帰という形で実行していますが、場合によっては解が求まらない場合もありえます。 | 例えば、 | J1 H1 H2 H3 H5 | J2 H2 H4 | J3 H1 H3 H5 | J4 H1 H2 H3 H4 H5 | といったケースで実行すると、スタックオーバーフローを起こします。 | これは前提が想定していないケースだからですが、これに類したことが起きないとも | 限りませんので、一定の回数上限を設けたほうがよいかもしれません。
こういうケースがあるのなら、今のコードでは対応ができないのです。 というのは、今のコードは、必要な時間数を受託希望の企業数（つまり4時間）にしています。 ですから、上記のケースでは、"J4"社は5時間が必要なのに時間が足りないわけです。 （もちろん、受託できる目処も立たないのに、そんなに面談するな、と制限すればいいわけですがね）
こういうケースがあるのかどうか、 受託企業数と、発注企業数との大体の比率とか 受託企業数と、発注企業数との関係で何か特徴的なことがあるのかどうか、 それも明らかにしたほうがよいと、前回質問したわけなんです。
（そして、本来は ・発注企業毎に見た受託企業数の最大数 ・受託企業毎に見た発注企業数の最大数 のいずれか大きい方を、必要な時間数にすれば、よいわけですね。）
（γ） 2020/09/20(日) 07:39
回答が遅くなり申し訳ございません。
まず、企業数ですが、都度都度変わりますが、ざっくりJ企業が20-40ぐらい、H企業が40〜70企業ぐらい
だったように記憶しております。（直近のデータしか手元にないため、ざっくりです・・・。
というのは、今のコードは、必要な時間数を受託希望の企業数（つまり4時間）にしています。 ですから、上記のケースでは、"J4"社は5時間が必要なのに時間が足りないわけです。 （もちろん、受託できる目処も立たないのに、そんなに面談するな、と制限すればいいわけですがね）
なるほど、そういうことなんですね。
たまたまなのか、経験論なのか、計算しているのかは不明なのですが、希望数の上限は時間数と等しく
設定するルールになっています。やはり都度都度ぶれますが、7〜8時間（10までいかない数だったと
思います）ぐらいでしょうか・・・
それも明らかにしたほうがよいと、前回質問したわけなんです。
大変失礼いたしました。m(__)m
受託企業数と、発注企業数との大体の比率とか 受託企業数と、発注企業数との関係で何か特徴的なことがあるのかどうか、
特徴的なこと・・・。人気がある企業とそうでない企業にかなりの差がある、ぐらいでしょうか・・・
申し訳ございません、あまりその辺り気にせずやってきたようして・・・
（KP） 2020/09/20(日) 16:25
イメージだけでは伝わりにくいかと思い直し、修正案をアップしておきます。 以下は、2020/09/17(木) 23:14の投稿と差があるプロシージャのみです。
申し訳ございません、こちらを見落としておりました。ありがとうございます。
拝見させていただきます。
（KP） 2020/09/20(日) 16:32
ご返信にお時間が空いてしまい大変申し訳ございません。m(__)m
毎回で誠に恐れ入りますが、覚えが悪くロジックの理解に時間がかかってしまいました・・・
お忙しいところありがとうございますm(__)m
できるだけ多くのデータで試行して動作確認ができればと考えております。
本件につきまして、遅出と早帰りに加え、連続で歯抜けがでない（商談あり-空き-空き-商談あり）
ようにするため、下記を加えてみました。（非効率かつ無駄が多く、限定条件が多いコードでお恥ずかしいです・・・。考え方は合っておりますでしょうか・・・。）
pointとpoint2の重みづけについては、実際に数をこなして落としどころを探れればと考えております。
【主な追加部分】
Function 待ち期間計算(ByVal yy As Variant, ByVal k As Long) As Long
Dim r&, c&, points&
Dim r2&, c2&, points2&
（中略）
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-商談あり」だった場合にpoint2を1減算
For c2 = 2 To UBound(yy, 2) - 3
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (Not IsEmpty(yy(r2, c2 + 3))) Then
points2 = points2 - 1
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-商談あり」だった場合にpoint2を2減算
For c2 = 2 To UBound(yy, 2) - 4
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (Not IsEmpty(yy(r2, c2 + 4))) Then
points2 = points2 - 2
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-空き-商談あり」だった場合にpoint2を3減算
For c2 = 2 To UBound(yy, 2) - 5
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (IsEmpty(yy(r2, c2 + 4))) And (Not IsEmpty(yy(r2, c2 + 5))) Then
points2 = points2 - 3
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-空き-空き-商談あり」だった場合にpoint2を4減算
For c2 = 2 To UBound(yy, 2) - 6
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (IsEmpty(yy(r2, c2 + 4))) And (IsEmpty(yy(r2, c2 + 5))) And (Not IsEmpty(yy(r2, c2 + 6))) Then
points2 = points2 - 4
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-空き-空き-空き-商談あり」だった場合にpoint2を5減算
For c2 = 2 To UBound(yy, 2) - 7
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (IsEmpty(yy(r2, c2 + 4))) And (IsEmpty(yy(r2, c2 + 5))) And (IsEmpty(yy(r2, c2 + 6))) And (Not IsEmpty(yy(r2, c2 + 7))) Then
points2 = points2 - 5
Debug.Print points2
End If
Next
Next
（中略）
待ち期間計算 = (UBound(yy, 1) - 1) * (UBound(yy, 2) - 1) - k - points - points2
【コード全体】
Option Explicit
' ＶＢＡによるメルセンヌツイスタ
' システムを起動してからの時間をミリ秒単位で返す
' http://msdn.microsoft.com/ja-jp/library/cc429827.aspx
'Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare PtrSafe 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 てすと2()
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
Dim kk As Long
Dim MyFlg As Boolean
Dim t
t = Timer
Application.ScreenUpdating = False '画面描画停止
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
' ■以下に手を入れました。
Dim trial As Long
Dim 待ち期間 As Long
Dim 暫定最小待ち期間 As Long
Dim 最適yy As Variant
暫定最小待ち期間 = 10000
For trial = 1 To 10 ' ■ 10は勿論、仮置きの回数です。必要に応じて修正してください。
DoEvents
Application.StatusBar = trial
探索 MyDic, Tempyy, yy, k, kk, MyFlg
With Sheets("Sheet2")
.Cells.Clear
If MyFlg = False Then
.Range("A1").Resize(UBound(yy, 1), UBound(yy, 2)).Value = yy '出力不要かも
待ち期間 = 待ち期間計算(yy, k)
' Debug.Print 待ち期間; Tab(10); trial
If 待ち期間 < 暫定最小待ち期間 Then
暫定最小待ち期間 = 待ち期間
最適yy = yy
End If
Else
'''MsgBox "規定数に達しました。" 'ここはコメントにしました。
End If
End With
MyFlg = False
kk = 0
Next
'最終結果
Sheets("Sheet2").Range("A1").Resize(UBound(最適yy, 1), UBound(最適yy, 2)).Value = 最適yy
Set MyDic = Nothing
Erase v, y, yy, x, Tempyy
Application.StatusBar = False
' Debug.Print Timer - t
Application.ScreenUpdating = True '画面描画再開
End Sub
Function 待ち期間計算(ByVal yy As Variant, ByVal k As Long) As Long
Dim r&, c&, points&
Dim r2&, c2&, points2&
For r = 2 To UBound(yy, 1)
For c = 2 To UBound(yy, 2)
If IsEmpty(yy(r, c)) Then
points = points + 1
Else
Exit For
End If
Next
For c = UBound(yy, 2) To 2 Step -1
If IsEmpty(yy(r, c)) Then
points = points + 1
Else
Exit For
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-商談あり」だった場合にpoint2を1減算
For c2 = 2 To UBound(yy, 2) - 3
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (Not IsEmpty(yy(r2, c2 + 3))) Then
points2 = points2 - 1
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-商談あり」だった場合にpoint2を2減算
For c2 = 2 To UBound(yy, 2) - 4
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (Not IsEmpty(yy(r2, c2 + 4))) Then
points2 = points2 - 2
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-空き-商談あり」だった場合にpoint2を3減算
For c2 = 2 To UBound(yy, 2) - 5
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (IsEmpty(yy(r2, c2 + 4))) And (Not IsEmpty(yy(r2, c2 + 5))) Then
points2 = points2 - 3
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-空き-空き-商談あり」だった場合にpoint2を4減算
For c2 = 2 To UBound(yy, 2) - 6
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (IsEmpty(yy(r2, c2 + 4))) And (IsEmpty(yy(r2, c2 + 5))) And (Not IsEmpty(yy(r2, c2 + 6))) Then
points2 = points2 - 4
End If
Next
Next
For r2 = 2 To UBound(yy, 1) '「商談あり-空き-空き-空き-空き-空き-空き-商談あり」だった場合にpoint2を5減算
For c2 = 2 To UBound(yy, 2) - 7
If (Not IsEmpty(yy(r2, c2))) And (IsEmpty(yy(r2, c2 + 1))) And (IsEmpty(yy(r2, c2 + 2))) And (IsEmpty(yy(r2, c2 + 3))) And (IsEmpty(yy(r2, c2 + 4))) And (IsEmpty(yy(r2, c2 + 5))) And (IsEmpty(yy(r2, c2 + 6))) And (Not IsEmpty(yy(r2, c2 + 7))) Then
points2 = points2 - 5
Debug.Print points2
End If
Next
Next
' 待ち期間計算 = (UBound(yy, 1) - 1) * (UBound(yy, 2) - 1) - k - points
待ち期間計算 = (UBound(yy, 1) - 1) * (UBound(yy, 2) - 1) - k - points - points2
End Function
Sub 探索(ByVal MyDic As Object, ByVal Tempyy As Variant, ByRef yy As Variant, ByVal k As Long, ByRef 回数 As Long, ByRef MyFlg As Boolean)
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
'' Const 上限 As Long = 10 '10回だと解が見つからないことが多かったので。
Const 上限 As Long = 100
Dim 空き As Long
Dim v As Variant
回数 = 回数 + 1
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 mycounta(x) = 0 Then Exit For
Next
If mycounta(x) = 0 Then Exit For
Next
Next
If 回数 > 上限 Then
MyFlg = True
Exit Sub
End If
If k <> n Then 探索 MyDic, Tempyy, yy, k, 回数, MyFlg
End Sub
Private Sub MyFScs(ByRef x As Variant)
Dim y As Variant
Dim i As Long
Dim j As Long
ReDim y(LBound(x, 1) + 1 To UBound(x, 1) + 1, 1 To 2)
For i = LBound(x, 1) To UBound(x, 1)
y(i + 1, 1) = x(i)
y(i + 1, 2) = Round(NextUnifMt(), 5)
Next
QuickSort y, 2, LBound(y, 1), UBound(y, 1)
For i = LBound(x, 1) To UBound(x, 1)
x(i) = y(i + 1, 1)
Next
Erase y
End Sub
Private Sub QuickSort(MySAry As Variant, ByVal MySKey As Long, ByVal MySLeft As Long, ByVal MySRight As Long)
Dim MySMid As Double
Dim i As Long, j As Long, n As Long
Dim MySLBound As Long, MySUBound As Long
Dim MyStmp As Variant
MySLBound = LBound(MySAry, 2)
MySUBound = UBound(MySAry, 2)
MySMid = MySAry((MySLeft + MySRight) \ 2, MySKey)
i = MySLeft
j = MySRight
Do
Do While MySAry(i, MySKey) > MySMid
i = i + 1
Loop
Do While MySAry(j, MySKey) < MySMid
j = j - 1
Loop
If i >= j Then Exit Do
For n = MySLBound To MySUBound
MyStmp = MySAry(i, n)
MySAry(i, n) = MySAry(j, n)
MySAry(j, n) = MyStmp
Next
i = i + 1
j = j - 1
Loop
If MySLeft < i - 1 Then QuickSort MySAry, MySKey, MySLeft, i - 1
If MySRight > j + 1 Then QuickSort MySAry, MySKey, j + 1, MySRight
End Sub
Function mycounta(ByVal v As Variant) As Long
Dim x As Variant
For Each x In v
If x <> "" Then mycounta = mycounta + 1
Next
End Function
（KP） 2020/09/25(金) 11:40
こんばんは！ γさんのロジックはわかりませんが、、連続した待ち時間の少ないパターンを選ぶ様にしてみました。 考え方は取り合えず実行してみて連続した待ち時間の数を数えます。 その待ち時間の最小値が5回更新されなければその時の結果を最適値として採用します。 サンプルデータが乏しいのと私の能力が足りないのとで上手く行かないパターンも出てくるかもしれませんが、、参考出展させてください。
しかし、長くなりましたね。。。もうトピ主さんのコードも読んでませんし試してもいません。。。すみません。m(__)m てすと5は、4がいやなので5にしているだけです。
変更・追加したコードだけUpしておきます。良かったら試してみてください。
では、、では、、、
Sub てすと7()
Dim MyDic As Object
Dim v As Variant
Dim y As Variant
Dim yy() As Variant
Dim Tempyy As Variant
Dim Tempy As Long
Dim Temp待ち時間 As Long
Dim 最適yy As Variant
Dim 最終yy As Variant
Dim x As Variant
Dim z As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim kk As Long
Dim n As Long
Static 開始 As Boolean
Static 最小待ち時間 As Long
Dim MyFlg As Boolean
v = Sheets("Sheet1").Range("A1").CurrentRegion.Value
If UBound(v, 1) < UBound(v, 2) - 1 Then
MsgBox "企業に対して商談数が適正ではありません。"
Erase v
Exit Sub
End If
If 開始 = False Then
最小待ち時間 = 10000
開始 = True
End If
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
Do
ReDim y(0)
ReDim yy(0)
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
Temp待ち時間 = 1000
Tempyy = yy
Tempy = 10000
Do
RandomizeMt
kk = 0
MyFlg = False
探索 MyDic, Tempyy, yy, k, kk, MyFlg
チェック yy, y
If Tempy > MyCount(y) Then
Tempy = MyCount(y)
最適yy = yy
Else
n = n + 1
End If
Loop Until n > 10
最終Up 最適yy
最終Dn 最適yy
If Temp待ち時間 >= 待ち時間(最適yy) Then
Temp待ち時間 = 待ち時間(最適yy)
If 最小待ち時間 >= 待ち時間(最適yy) Then 最小待ち時間 = 待ち時間(最適yy)
最終yy = 最適yy
End If
Loop Until 最小待ち時間 = 待ち時間(最終yy)
With Sheets("Sheet2")
.Cells.Clear
If MyFlg Then MsgBox "規定数に達しました。"
If IsArray(最終yy) Then
.Range("A1").Resize(UBound(yy, 1), UBound(yy, 2)).Value = 最終yy
MsgBox "待ち時間は " & 待ち時間(最終yy) & " です。"
End If
End With
Set MyDic = Nothing
Erase v, y, yy, x, Tempyy, 最適yy, 最終yy
End Sub
Function 待ち時間(ByVal y As Variant) As Long
Dim z As Variant
Dim i As Long
Dim j As Long
Dim n As Long
Dim MyFlgS As Boolean
For i = LBound(y, 1) + 1 To UBound(y, 1)
MyFlgS = False
n = 0
For j = LBound(y, 2) + 1 To UBound(y, 2)
If y(i, j) <> "" Then
MyFlgS = True
End If
If MyFlgS Then
If y(i, j) = "" Then
n = n + 1
Else
待ち時間 = 待ち時間 + n
n = 0
End If
End If
Next
Next
End Function
Sub 最終Up(ByRef y As Variant)
Dim z As Variant
Dim i As Long
Dim j As Long
For i = UBound(y, 1) To LBound(y, 1) + 2 Step -1
For j = UBound(y, 2) To LBound(y, 2) + 2 Step -1
If y(i, j) = "" Then
If y(i, j - 1) <> "" Then
z = Application.Match(y(i, j - 1), Application.Index(y, 0, j), 0)
If IsError(z) Then
y(i, j) = y(i, j - 1)
y(i, j - 1) = ""
End If
End If
End If
Next
Next
End Sub
Sub 最終Dn(ByRef y As Variant)
Dim z As Variant
Dim i As Long
Dim j As Long
For i = LBound(y, 1) + 1 To UBound(y, 1) - 1
For j = LBound(y, 2) + 1 To UBound(y, 2) - 1
If y(i, j) = "" Then
If y(i, j + 1) <> "" Then
z = Application.Match(y(i, j + 1), Application.Index(y, 0, j), 0)
If IsError(z) Then
y(i, j) = y(i, j + 1)
y(i, j + 1) = ""
End If
End If
End If
Next
Next
End Sub
Function MyCount(ByVal y As Variant) As Long
Dim v As Variant
For Each v In y
If v > 1 Then MyCount = MyCount + 1
If v = 0 Then
MyCount = 0
Exit Function
End If
Next
End Function
Sub チェック(ByVal v As Variant, ByRef y As Variant)
Dim i As Long
Dim j As Long
Dim n As Long
Dim 最大値 As Long
Dim MyFlg As Boolean
ReDim y(UBound(v, 1))
For i = LBound(v, 1) + 1 To UBound(v, 1)
MyFlg = False
最大値 = 0
For j = LBound(v, 2) + 1 To UBound(v, 2)
If v(i, j) <> "" Then MyFlg = True
If MyFlg Then
If v(i, j) = "" Then n = n + 1
If 最大値 < n Then 最大値 = n
y(i) = 最大値
If v(i, j) <> "" Then n = 0
End If
Next
Next
End Sub
Sub 探索(ByVal MyDic As Object, ByVal Tempyy As Variant, ByRef yy As Variant, ByVal k As Long, ByRef 回数 As Long, ByRef MyFlg As Boolean)
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
Const 上限 As Long = 100
Dim 空き As Long
Dim v As Variant
回数 = 回数 + 1
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
'-------------------------------------------------
空き = 0
For Each v In Application.Index(yy, i, 0)
If v = "" Then 空き = 空き + 1
Next
' MsgBox "空きは " & 空き & " 個です。"
'-------------------------------------------------
' Debug.Print mycounta(Application.Index(yy, i, 0))
Exit For
End If
End If
End If
If mycounta(x) = 0 Then Exit For
Next
If mycounta(x) = 0 Then Exit For
Next
Next
If 回数 > 上限 Then
MyFlg = True
Exit Sub
End If
If k <> n Then 探索 MyDic, Tempyy, yy, k, 回数, MyFlg
End Sub
チャレンジを20回にしたのと変数処理を追加しました。
すみません。チェックを修正しました。m(__)m
連続の空き時間がないパターンを作った後に最終Upと最終Dnで前後に詰めます。
頭がないので力技ですね(^^;
もう取り合えず寝ます。
おやすみなさいzzzzzzzzzzzzzzzzzzzzzzz
（SoulMan） 2020/09/25(金) 20:36
いつもお世話になっております。
重ね重ねありがとうございます。m(__)m
素晴らしいです。
週末を使って、頂戴したソースの読み込み＋色々なデータで試行してみます。
試行結果は改めてご報告させて頂きます。
お忙しいところありがとうございました。m(__)m
（KP） 2020/09/26(土) 07:28
おはようございます。 細部を少し見直しました。 RandomizeMt をループの中に入れて MyCountで完全に振り分け出来たフレーズがあればそれを採用するようにしてみました。 If v = 0 Then MyCount = 0 それから最初に解けないデータははじくようにしました。 MsgBox "企業に対して商談数が適正ではありません。"
後からの追加訂正で全体がつかめてないかもしれませんが頑張ってください。
では、、では、、 （SoulMan） 2020/09/26(土) 09:13
すみません。 0を発見したらループを抜けないと意味がない様に思うので MyCountを↓に差し替えてください。 悪いパターンも少しでますね？ちょっとわけがわからなくなってきましたね(^^; いいころ合いで妥協してください(おぉぉぉいいっ！！！）
Function MyCount(ByVal y As Variant) As Long
Dim v As Variant
For Each v In y
If v > 1 Then MyCount = MyCount + 1
If v = 0 Then
MyCount = 0
Exit Function
End If
Next
End Function
（SoulMan） 2020/09/26(土) 09:55
更にそれを10回実施して待ち時間の最も少ないものを最終yyとして採用するようにしてみました。。。 この辺でどうでしょう？ （SoulMan） 2020/09/26(土) 13:16
何度もありがとうございます。助かります。m(__)m
勉強＋色々と試してみた後、改めてご報告させていただきます。
（KP） 2020/09/26(土) 13:29
最小の待ち時間を更新したら以降はその最小の待ち時間になるまで繰り返します。 ただ与えるデータが変わった時は何か別のアクションを入れないと無限ループになります。
最小待ち時間が 3 → 2 → 1 → 1 → 1 こんなイメージです。 実行するたびに賢くなるのですね(^^;
もうちょっとやってみますぅ？？？？ （SoulMan） 2020/09/26(土) 17:50
なるほど、そういう仕組みなのですね。
色々なデータで試していたのですが、データ数が大きくなると結構な確率で
考え込んでしまうので不思議に思っていました。
（仕組みを理解していないのが最たる原因ですので、もう少し勉強します。）
ただ与えるデータが変わった時は何か別のアクションを入れないと無限ループになります。
何度も申し訳ございません。どんな感じにすればよいかご教示をお願いしてもよろしいでしょうか。
（KP） 2020/09/26(土) 21:08
一番簡単なのは てすと を一度閉じるのが一番簡単なんですけど、、 そうもいかないでしょうから、、てすと に引数を渡して 例えば 一回目はスタートで開始して 二回目以降は 継続 で継続するとか。。。
もう名前を考えるのが大変でしょ？(^^; もうこの辺で満足しましたか？？？
Sub スタート()
てすと False
End Sub
Sub 継続()
てすと True
End Sub
Sub てすと(ByVal 開始 As Boolean)
Dim MyDic As Object
Dim v As Variant
Dim y As Variant
Dim yy() As Variant
Dim Tempyy As Variant
Dim Tempy As Long
Dim Temp待ち時間 As Long
Dim 最適yy As Variant
Dim 最終yy As Variant
Dim x As Variant
Dim z As Variant
Dim i As Long
Dim j As Long
Dim k As Long
Dim kk As Long
Dim n As Long
Dim 脱出弾 As Long
Static 最小待ち時間 As Long
Dim MyFlg As Boolean
v = Sheets("Sheet1").Range("A1").CurrentRegion.Value
If UBound(v, 1) < UBound(v, 2) - 1 Then
MsgBox "企業に対して商談数が適正ではありません。"
Erase v
Exit Sub
End If
If 開始 = False Then
最小待ち時間 = 10000
開始 = True
End If
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
Do
脱出弾 = 脱出弾 + 1
If 脱出弾 > 200 Then
MsgBox "脱出します"
Exit Sub
End If
ReDim y(0)
ReDim yy(0)
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
Temp待ち時間 = 1000
Tempyy = yy
Tempy = 10000
Do
RandomizeMt
kk = 0
MyFlg = False
探索 MyDic, Tempyy, yy, k, kk, MyFlg
チェック yy, y
If Tempy > MyCount(y) Then
Tempy = MyCount(y)
最適yy = yy
Else
n = n + 1
End If
Loop Until n > 10
最終Up 最適yy
最終Dn 最適yy
If Temp待ち時間 >= 待ち時間(最適yy) Then
Temp待ち時間 = 待ち時間(最適yy)
If 最小待ち時間 >= 待ち時間(最適yy) Then 最小待ち時間 = 待ち時間(最適yy)
最終yy = 最適yy
End If
Loop Until 最小待ち時間 = 待ち時間(最終yy)
With Sheets("Sheet2")
.Cells.Clear
If MyFlg Then MsgBox "規定数に達しました。"
If IsArray(最終yy) Then
.Range("A1").Resize(UBound(yy, 1), UBound(yy, 2)).Value = 最終yy
MsgBox "待ち時間は " & 待ち時間(最終yy) & " です。"
End If
End With
Set MyDic = Nothing
Erase v, y, yy, x, Tempyy, 最適yy, 最終yy
End Sub
（SoulMan） 2020/09/26(土) 22:05
二回目以降は、継続 といっても最初から押したくなるのが人間ですよねぇ(^^; 脱出弾を入れました(笑) （SoulMan） 2020/09/26(土) 22:31
駄駄をこねないで SoulMan さんも疲れていそうだから解放してあげなよ。
（FG） 2020/09/26(土) 22:45
何度も申し訳ございませんでした。
ありがとうございます。もう充分でございます。立て続けでご迷惑をおかけしました。
ご無理を申し上げました。m(__)m
後は、試行結果のご報告だけさせていただければと存じます。
FG 様
ご指摘ありがとうございます。
おっしゃる通りです、周りが見えなくなっておりました。
（KP） 2020/09/27(日) 07:31
いつもお世話になっております。
本件、お忙しいところご迷惑をおかけし申し訳ございませんでした。m(__)m
まだ途中ですが、試行結果の途中経過をご報告させて頂きます。
J：28社
H：70社
第8希望まで希望を聴取 => 最終時間割は8時間
のリアルデータで試しました。（試行回数がまだ足りないので一例です。）
J視点の時間割
旧マクロ：歯抜け時間=2
新マクロ：歯抜け時間=0
H視点の時間割
旧マクロ
歯抜けあり：24社
歯抜け時間総数：48時間
歯抜け内訳：1時間空き×7社、2時間以上空き：17社
新マクロ
歯抜けあり：21社
歯抜け時間総数：47時間
歯抜け内訳：1時間空き×4社、2時間以上空き：17社
でした。
どうしても人気の高い企業の組み合わせがネックになり、空き時間はどうやっても
生じてしまう部分はありますが、それ以外の部分は矛盾なく最適化できるため、
数字だけですと歯抜けが多いようにも見えますが、実際はほんの少し手修正を加える
だけでそのまま使わせて頂くことができそうです。
また、キャンセルや変更が入った際、即座に組み直せるのがすごくありがたいです。
この度は、大変お世話になりました。ありがとうございます。m(__)m
（KP） 2020/09/28(月) 15:17
こんばんは！ 解決されてよかったです。 ところで最終Upと最終Dnを↓下のコードに差し替えてください。
Endの停止位置が間違っている点と最終Upで後ろに詰めたものを最終Dnでまた戻すことがない様に 移動させたものに"@"という印をつけました。"@"はあり得ない文字にしてください。
最終Upで後ろに詰めて最終Dnでは"@"の付いたものは移動させずに"@"を消すだけです。 とは言っても一度、最小待ち時間を見つけてからは最小待ち時間になるまで繰り返しますから あまり変化はないかもしれませんがデータが多くなると多少変化があるかもしれません。
それと最小待ち時間を見つけるまでの外側のLoopはyyを作るとこから始まっていますが、 初期yyという変数を追加して最初のyyを代入しておけば多少は無駄を省けると思います。
その他にも気になる点はいくつかありますが、このトピは長くなってしまったのでまた別の機会にされた方がいいでしょう。 トピが長くなると他の回答者の方が参加しずらくなります。結果、不利益を受けるのはトピ主さんなのですね。 今回のコードは変更追加訂正で見落としが沢山あると思います。
トピ主さんは熱心な方なのでよぉ〜〜く見ればきっと解決されると思います。頑張ってください。 では、、では、、また v(=∩_∩=)v
Sub 最終Up(ByRef y As Variant)
Dim z As Variant
Dim i As Long
Dim j As Long
For i = UBound(y, 1) To LBound(y, 1) + 1 Step -1
For j = UBound(y, 2) To LBound(y, 2) + 2 Step -1
If y(i, j) = "" Then
If y(i, j - 1) <> "" Then
z = Application.Match(y(i, j - 1), Application.Index(y, 0, j), 0)
If IsError(z) Then
y(i, j) = "@" & y(i, j - 1)
y(i, j - 1) = ""
End If
End If
End If
Next
Next
End Sub
Sub 最終Dn(ByRef y As Variant)
Dim z As Variant
Dim i As Long
Dim j As Long
For i = LBound(y, 1) + 1 To UBound(y, 1)
For j = LBound(y, 2) + 1 To UBound(y, 2) - 1
If y(i, j) = "" Then
If y(i, j + 1) <> "" Then
If InStr(y(i, j + 1), "@") > 0 Then
y(i, j + 1) = Replace(y(i, j + 1), "@", "")
Else
z = Application.Match(y(i, j + 1), Application.Index(y, 0, j), 0)
If IsError(z) Then
y(i, j) = y(i, j + 1)
y(i, j + 1) = ""
End If
End If
End If
End If
Next
Next
End Sub
（SoulMan） 2020/09/28(月) 20:07
内容理解はまだ少し時間がかかりそうですが・・・(^^;
変数の名前変更もまだ途中ですが、一つでも見落とすとエラーが出るので、確かに勉強になりますね。
トピ主さんは熱心な方なのでよぉ〜〜く見ればきっと解決されると思います。頑張ってください。 では、、では、、また v(=∩_∩=)v
承知いたしました。頑張ります。
この度は、本当にありがとうございました。m(__)m
（KP） 2020/09/29(火) 08:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.