-
2012/09/20 (Thu) 00:38:49
_Kyle(1291004)
qa7697154： ボツコード
-
URL /
Comment
'-----------------------------------------------------------
'■Q「アルゴリズムについての質問です」
'bekkoame.okwave.jp/qa7697154.html
'再帰でどこまでやれるか実験ちう
'
' ※質問文の元コードには変数minの宣言がありません。
' おそらく、
' 別モジュールでPublic変数として宣言してあるものと思われます。
'
Dim MIN As Integer '投稿者追記
'-----------------------------------------------------------
'-----↓元コードココカラ↓------------------------
Dim 重みtab As Variant
Dim t01(100) As Integer '←A群が、「t01(1)」から順に入っています。
Dim t02(100) As Integer '←B群が、「t02(1)」から順に入っています。
Dim ttt(100) As Integer '←B群を並び替えた結果が入ります。
Sub 計算(移動数 As Integer) '「移動数」は「t01」「t02」の要素の数
Dim t03(100) As Integer
Dim a As Integer
重みtab = Range("重み表") 'Range("重み表") は ＜図１＞の「No」を含まないセル
'仮の最小の計算--------
MIN = 0
For a = 1 To 移動数
MIN = MIN + 重みtab(t01(a), t02(a))
ttt(a) = a
Next
'----------------------
Call 再帰関数(移動数, t03, 1)
'Sheet2に出力----------
For a = 1 To 移動数
Sheets("Sheet2").Cells(a, 1) = t01(a)
Sheets("Sheet2").Cells(a, 2) = t02(ttt(a))
Next
'----------------------
End Sub
Sub 再帰関数(移動数 As Integer, t03() As Integer, cnt1 As Integer)
Dim cnt2 As Integer
Dim flg As Boolean
For a = 1 To 移動数
flg = True
For b = 1 To cnt1 - 1
If t03(b) = a Then
flg = False
End If
Next
If flg Then
t03(cnt1) = a
If cnt1 < 移動数 Then
cnt2 = cnt1
cnt1 = cnt1 + 1
Call 再帰関数(移動数, t03, cnt1)
cnt1 = cnt2
Else
Call 処理(移動数, t03)
End If
t03(cnt1) = 0
End If
Next
End Sub
Sub 処理(移動数 As Integer, t03() As Integer) '最小であるか確認
Dim a As Integer
Dim b As Integer
For a = 1 To 移動数
b = b + 重みtab(t01(a), t02(t03(a)))
Next
If MIN > b Then
MIN = b
For a = 1 To 移動数
ttt(a) = t03(a)
Next
End If
End Sub
'-----↑元コードココマデ↑------------------------
'-----------------------------------------------------------
-
2012/09/28 (Fri) 18:04:07
_Kyle(1291004) - (11) 潜る前に判定
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(11) 潜る前に判定
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14806441
'
'memAryの判定前倒しにして再帰数減らしてみた。
'
'部屋数18，移動数20で10回テストして
' 最短 38msec. 再帰数 252回
' 最長 427msec. 再帰数 34,024回
'
'部屋数18，移動数30で10回テストして
' 最短 515msec. 再帰数 61,110回
' 最長 22,129msec. 再帰数 1,390,492回
'
'※要参照設定：Microsoft Scripting Runtime
'
'-----------------------------------------------------------
'-------------------------------------------------
'◆元質設定
Dim t01(100) As Integer '事前設定
Dim t02(100) As Integer '事前設定
Dim ttt(100) As Integer '結果
Dim min As Integer '結果
'-------------------------------------------------
'◆宣言
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const movLmt As Long = 94 '移動数上限
Private Const romLmt As Long = 20 '部屋数上限
Private cstTbl() As Long
Private dstTbl(movLmt, movLmt) As Long
Private outDsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private outAry(romLmt, 1) As Long
Private in_Dsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private in_Ary(romLmt, 1) As Long
Private tmpAry(romLmt, movLmt) As Long
Private rtnAry() As Long
Private dicAry() As Dictionary
Private chrAry() As String
Private movCnt As Long
Private outCnt As Long
Private in_Cnt As Long
Private bstCst As Long
Private memStr As String
Private t As Long
Private c As Long
'-------------------------------------------------
'◆起動処理
Sub k0CLC_t11()
Dim 移動数 As Integer
Dim i As Long
Erase t01, t02, ttt
'↓ココは事前に入ってる要件
With Range("課題表")
移動数 = 0
For i = 1 To .Rows.Count
t01(i) = .Cells(i, 1).Value
t02(i) = .Cells(i, 2).Value
If t01(i) = 0 Then Exit For
移動数 = 移動数 + 1
Next i
End With
c = 0
t = timeGetTime
Call k0CLC(移動数)
Debug.Print "t11", timeGetTime - t, c, bstCst, movCnt
End Sub
'-------------------------------------------------
'◆親Ｐ
Private Sub k0CLC(ByRef 移動数 As Integer)
'宣言---------------------------------
Dim tmpCst As Long
movCnt = 移動数
'予備処理-----------------------------
Call k0CLC_pre(tmpCst, "重み表")
'主処理-------------------------------
Call k0CLC_rcs(tmpCst, 1, 1)
'書出・終了---------------------------
Call k0CLC_end("Sheet2", "A1", "B1")
End Sub
'-------------------------------------------------
'◆主処理
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long, _
ByVal in_Stt As Long _
)
c = c + 1
Dim in_Idx As Long
Dim rmnCnt As Long
Dim bufCst As Long
Dim bufStr As String
Dim i As Long
bufStr = memStr
If outDsk(outIdx, 0) > outDsk(outIdx - 1, 0) Then
in_Stt = 1
End If
For i = in_Stt To in_Cnt
in_Idx = dstTbl(outIdx, i)
rmnCnt = in_Ary(in_Idx, 1)
If rmnCnt > 0 Then
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
tmpAry(in_Idx, rmnCnt) = outIdx
in_Ary(in_Idx, 1) = rmnCnt - 1
If outIdx = movCnt Then
Call k0CLC_nrc(bufCst)
i = in_Cnt
Else
Mid(memStr, in_Idx, 1) = chrAry(rmnCnt)
With dicAry(outIdx + 1)
If .Exists(memStr) Then
If .Item(memStr) > bufCst Then
.Item(memStr) = bufCst
Call k0CLC_rcs(bufCst, outIdx + 1, i)
End If
Else
.Add memStr, bufCst
Call k0CLC_rcs(bufCst, outIdx + 1, i)
End If
End With
memStr = bufStr
End If
in_Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
End If
End If
Next i
End Sub
'-------------------------------------------------
'◆暫定ベスト更新
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
End Sub
'-------------------------------------------------
'◆予備処理
Private Sub k0CLC_pre( _
ByRef tmpCst As Long, ByRef tblNme As String)
'宣言---------------------------------
Dim WSF As WorksheetFunction
Dim outTmp As Variant
Dim in_Tmp As Variant
Dim tmpRow As Variant
Dim minCst As Long
Dim i As Long
Dim j As Long
Dim k As Long
Set WSF = Application.WorksheetFunction
'初期化-------------------------------
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, dicAry, chrAry
ReDim rtnAry(movLmt, movLmt)
'配列準備-----------------------------
ReDim outTmp(1 To movCnt)
ReDim in_Tmp(1 To movCnt)
With WSF
For i = 1 To movCnt
outTmp(i) = t01(i) + i / (movCnt + 1)
in_Tmp(i) = t02(i) + i / (movCnt + 1)
Next i
outCnt = 0
in_Cnt = 0
For i = 1 To movCnt
'◆out
outDsk(i, 3) = .Match(.Small(outTmp, i), outTmp, 0)
outDsk(i, 0) = Int(outTmp(outDsk(i, 3)))
If outDsk(i, 0) <> outDsk(i - 1, 0) Then
outCnt = outCnt + 1
outAry(outCnt, 0) = outDsk(i, 0)
outAry(outCnt, 1) = 1
Else
outAry(outCnt, 1) = outAry(outCnt, 1) + 1
End If
outDsk(i, 1) = outCnt
outDsk(i, 2) = outAry(outCnt, 1)
'◆in
in_Dsk(i, 3) = .Match(.Small(in_Tmp, i), in_Tmp, 0)
in_Dsk(i, 0) = Int(in_Tmp(in_Dsk(i, 3)))
If in_Dsk(i, 0) <> in_Dsk(i - 1, 0) Then
in_Cnt = in_Cnt + 1
in_Ary(in_Cnt, 0) = in_Dsk(i, 0)
in_Ary(in_Cnt, 1) = 1
Else
in_Ary(in_Cnt, 1) = in_Ary(in_Cnt, 1) + 1
End If
in_Dsk(i, 1) = in_Cnt
in_Dsk(i, 2) = in_Ary(in_Cnt, 1)
Next i
End With
'コストテーブル読み込み---------------
With Range(tblNme)
ReDim cstTbl(1 To movCnt, 1 To in_Cnt)
For i = 1 To movCnt
For j = 1 To in_Cnt
cstTbl(i, j) = _
.Cells(outDsk(i, 0), in_Ary(j, 0)).Value
Next j
Next i
ReDim pssAry(.Rows.Count, in_Cnt)
End With
'距離テーブル-------------------------
For i = 1 To movCnt
dstTbl(i, 0) = outDsk(i, 0)
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To in_Cnt
tmpRow(j) = tmpRow(j) + j / (in_Cnt + 1)
Next j
For j = 1 To in_Cnt
dstTbl(i, j) = _
WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
'初期暫定ベスト-----------------------
bstCst = 0
i = 0
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
i = i + 1
bstCst = bstCst + cstTbl(i, j)
rtnAry(j, k) = i
Next k
Next j
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
'最低コスト---------------------------
For i = 1 To movCnt
minCst = cstTbl(i, dstTbl(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To in_Cnt
cstTbl(i, dstTbl(i, j)) = _
cstTbl(i, dstTbl(i, j)) - minCst
Next j
Next i
'メモ---------------------------------
ReDim dicAry(1 To movCnt)
ReDim chrAry(1 To movCnt)
memStr = String$(in_Cnt, " ")
For i = 1 To movCnt
Set dicAry(i) = New Scripting.Dictionary
chrAry(i) = Chr(i + 32)
Next i
End Sub
'-------------------------------------------------
'◆書出・終了処理
Private Sub k0CLC_end( _
ByRef shtNme As String, _
ByRef outAds As String, _
ByRef in_Ads As String)
Dim i As Long
Dim j As Long
Dim k As Long
'結果書出-----------------------------
Application.ScreenUpdating = False
With Sheets(shtNme)
For i = 1 To movCnt
.Range(outAds).Cells(outDsk(i, 3), 1) = outDsk(i, 0)
Next i
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
.Range(in_Ads).Cells(outDsk(rtnAry(j, k), 3), 1) = in_Ary(j, 0)
ttt(rtnAry(j, k)) = in_Ary(j, 0)
Next k
Next j
End With
min = bstCst
'終了処理-----------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, rtnAry, dicAry, chrAry
End Sub
'-----------------------------------------------------------
-
2012/09/28 (Fri) 06:46:03
_Kyle(1291004) - (10) りふぁくたりんぐ３
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(10) りふぁくたりんぐ３
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14806441
'
't09もぐだぐだ過ぎたもよう orz
'
'部屋数18，要素20対で10回テストして
' 最短 62msec.
' 最長 539msec.
'
'※要参照設定：Microsoft Scripting Runtime
'
'-----------------------------------------------------------
'-------------------------------------------------
'◆元質設定
Dim t01(100) As Integer '事前設定
Dim t02(100) As Integer '事前設定
Dim ttt(100) As Integer '結果
Dim min As Integer '結果
'-------------------------------------------------
'◆宣言
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const movLmt As Long = 99 '移動数上限
Private Const romLmt As Long = 20 '部屋数上限
Private cstTbl() As Long
Private dstTbl(movLmt, movLmt) As Long
Private outDsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private outAry(romLmt, 1) As Long
Private in_Dsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private in_Ary(romLmt, 1) As Long
Private tmpAry(romLmt, movLmt) As Long
Private rtnAry() As Long
Private dicAry() As Dictionary
Private pntAry(romLmt) As Long
Private numAry() As String
Private movCnt As Long
Private outCnt As Long
Private in_Cnt As Long
Private bstCst As Long
Private memStr As String
Private t As Long
Private c As Long
'-------------------------------------------------
'◆起動処理
Sub k0CLC_t10()
Dim 移動数 As Integer
Dim i As Long
Erase t01, t02, ttt
'↓ココは事前に入ってる要件
With Range("課題表")
移動数 = 0
For i = 1 To .Rows.Count
t01(i) = .Cells(i, 1).Value
t02(i) = .Cells(i, 2).Value
If t01(i) = 0 Then Exit For
移動数 = 移動数 + 1
Next i
End With
c = 0
t = timeGetTime
Call k0CLC(移動数)
Debug.Print "t10", timeGetTime - t, c, bstCst, movCnt
End Sub
'-------------------------------------------------
'◆親Ｐ
Private Sub k0CLC(ByRef 移動数 As Integer)
'宣言---------------------------------
Dim tmpCst As Long
movCnt = 移動数
'予備処理-----------------------------
Call k0CLC_pre(tmpCst, "重み表")
'主処理-------------------------------
Call k0CLC_rcs(tmpCst, 1, 1)
'書出・終了---------------------------
Call k0CLC_end("Sheet2", "A1", "B1")
End Sub
'-------------------------------------------------
'◆主処理
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long, _
ByVal in_Stt As Long _
)
c = c + 1
Dim in_Idx As Long
Dim rmnCnt As Long
Dim bufCst As Long
Dim bufStr As String
Dim i As Long
With dicAry(outIdx)
If .Exists(memStr) Then
If .Item(memStr) <= tmpCst Then
Exit Sub
Else
.Item(memStr) = tmpCst
End If
Else
.Add memStr, tmpCst
End If
bufStr = memStr
End With
If outDsk(outIdx, 0) > outDsk(outIdx - 1, 0) Then
in_Stt = 1
End If
For i = in_Stt To in_Cnt
in_Idx = dstTbl(outIdx, i)
rmnCnt = in_Ary(in_Idx, 1)
If rmnCnt > 0 Then
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
tmpAry(in_Idx, rmnCnt) = outIdx
in_Ary(in_Idx, 1) = rmnCnt - 1
If outIdx = movCnt Then
Call k0CLC_nrc(bufCst)
i = in_Cnt
Else
Mid(memStr, pntAry(in_Idx), 2) = numAry(rmnCnt)
Call k0CLC_rcs(bufCst, outIdx + 1, i)
memStr = bufStr
End If
in_Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
End If
End If
Next i
End Sub
'-------------------------------------------------
'◆暫定ベスト更新
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
End Sub
'-------------------------------------------------
'◆予備処理
Private Sub k0CLC_pre( _
ByRef tmpCst As Long, ByRef tblNme As String)
'宣言---------------------------------
Dim WSF As WorksheetFunction
Dim outTmp As Variant
Dim in_Tmp As Variant
Dim tmpRow As Variant
Dim minCst As Long
Dim i As Long
Dim j As Long
Dim k As Long
Set WSF = Application.WorksheetFunction
'初期化-------------------------------
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, dicAry, numAry, pntAry
ReDim rtnAry(movLmt, movLmt)
'配列準備-----------------------------
ReDim outTmp(1 To movCnt)
ReDim in_Tmp(1 To movCnt)
With WSF
For i = 1 To movCnt
outTmp(i) = t01(i) + i / (movCnt + 1)
in_Tmp(i) = t02(i) + i / (movCnt + 1)
Next i
outCnt = 0
in_Cnt = 0
For i = 1 To movCnt
'◆out
outDsk(i, 3) = .Match(.Small(outTmp, i), outTmp, 0)
outDsk(i, 0) = Int(outTmp(outDsk(i, 3)))
If outDsk(i, 0) <> outDsk(i - 1, 0) Then
outCnt = outCnt + 1
outAry(outCnt, 0) = outDsk(i, 0)
outAry(outCnt, 1) = 1
Else
outAry(outCnt, 1) = outAry(outCnt, 1) + 1
End If
outDsk(i, 1) = outCnt
outDsk(i, 2) = outAry(outCnt, 1)
'◆in
in_Dsk(i, 3) = .Match(.Small(in_Tmp, i), in_Tmp, 0)
in_Dsk(i, 0) = Int(in_Tmp(in_Dsk(i, 3)))
If in_Dsk(i, 0) <> in_Dsk(i - 1, 0) Then
in_Cnt = in_Cnt + 1
in_Ary(in_Cnt, 0) = in_Dsk(i, 0)
in_Ary(in_Cnt, 1) = 1
Else
in_Ary(in_Cnt, 1) = in_Ary(in_Cnt, 1) + 1
End If
in_Dsk(i, 1) = in_Cnt
in_Dsk(i, 2) = in_Ary(in_Cnt, 1)
Next i
End With
'コストテーブル読み込み---------------
With Range(tblNme)
ReDim cstTbl(1 To movCnt, 1 To in_Cnt)
For i = 1 To movCnt
For j = 1 To in_Cnt
cstTbl(i, j) = _
.Cells(outDsk(i, 0), in_Ary(j, 0)).Value
Next j
Next i
ReDim pssAry(.Rows.Count, in_Cnt)
End With
'距離テーブル-------------------------
For i = 1 To movCnt
dstTbl(i, 0) = outDsk(i, 0)
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To in_Cnt
tmpRow(j) = tmpRow(j) + j / (in_Cnt + 1)
Next j
For j = 1 To in_Cnt
dstTbl(i, j) = _
WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
'初期暫定ベスト-----------------------
bstCst = 0
i = 0
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
i = i + 1
bstCst = bstCst + cstTbl(i, j)
rtnAry(j, k) = i
Next k
Next j
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
'最低コスト---------------------------
For i = 1 To movCnt
minCst = cstTbl(i, dstTbl(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To in_Cnt
cstTbl(i, dstTbl(i, j)) = _
cstTbl(i, dstTbl(i, j)) - minCst
Next j
Next i
'メモ---------------------------------
ReDim dicAry(1 To movCnt)
ReDim numAry(1 To movCnt)
memStr = String$(in_Cnt * 2, "0")
For i = 1 To movCnt
Set dicAry(i) = New Scripting.Dictionary
numAry(i) = Format(i, "00")
Next i
For i = 1 To in_Cnt
pntAry(i) = (i - 1) * 2 + 1
Next i
End Sub
'-------------------------------------------------
'◆書出・終了処理
Private Sub k0CLC_end( _
ByRef shtNme As String, _
ByRef outAds As String, _
ByRef in_Ads As String)
Dim i As Long
Dim j As Long
Dim k As Long
'結果書出-----------------------------
Application.ScreenUpdating = False
With Sheets(shtNme)
For i = 1 To movCnt
.Range(outAds).Cells(outDsk(i, 3), 1) = outDsk(i, 0)
Next i
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
.Range(in_Ads).Cells(outDsk(rtnAry(j, k), 3), 1) = in_Ary(j, 0)
ttt(rtnAry(j, k)) = in_Ary(j, 0)
Next k
Next j
End With
min = bstCst
'終了処理-----------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, rtnAry, dicAry, numAry, pntAry
End Sub
'-----------------------------------------------------------
-
2012/09/26 (Wed) 23:26:42
_Kyle(1291004) - (09) りふぁくたりんぐ２
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(09) りふぁくたりんぐ２
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14789474
'
't08はさすがにぐだぐだ過ぎたもよう orz
'
'部屋数18，要素20対で10回テストして
' 最短 82msec.
' 最長 474msec.
'
'※要参照設定：Microsoft Scripting Runtime
'
'-----------------------------------------------------------
'-------------------------------------------------
'◆元質設定
Dim t01(100) As Integer '事前設定
Dim t02(100) As Integer '事前設定
Dim ttt(100) As Integer '結果
Dim min As Integer '結果
'-------------------------------------------------
'◆宣言
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const movLmt As Long = 100 '移動数上限
Private Const romLmt As Long = 20 '部屋数上限
Private cstTbl() As Long
Private dstTbl(movLmt, movLmt) As Long
Private outDsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private outAry(romLmt, 1) As Long
Private in_Dsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private in_Ary(romLmt, 1) As Long
Private tmpAry(romLmt, movLmt) As Long
Private rvsAry(romLmt, movLmt) As Long
Private rtnAry() As Long
Private dicAry() As Dictionary
Private movCnt As Long
Private outCnt As Long
Private in_Cnt As Long
Private bstCst As Long
Private memStr As String
Private t As Long
Private c As Long
'-------------------------------------------------
'◆起動処理
Sub k0CLC_t09()
Dim 移動数 As Integer
Dim i As Long
Erase t01, t02, ttt
'↓ココは事前に入ってる要件
With Range("課題表")
移動数 = 0
For i = 1 To .Rows.Count
t01(i) = .Cells(i, 1).Value
t02(i) = .Cells(i, 2).Value
If t01(i) = 0 Then Exit For
移動数 = 移動数 + 1
Next i
End With
c = 0
t = timeGetTime
Call k0CLC(移動数)
Debug.Print "t09", timeGetTime - t, c, bstCst, movCnt
End Sub
'-------------------------------------------------
'◆親Ｐ
Private Sub k0CLC(ByRef 移動数 As Integer)
'宣言---------------------------------
Dim tmpCst As Long
'初期化-------------------------------
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, dicAry, rvsAry
ReDim rtnAry(movLmt, movLmt)
movCnt = 移動数
memStr = String$(movCnt, "0")
bstCst = 0
outCnt = 0
in_Cnt = 0
'予備処理-----------------------------
Call k0CLC_pre(tmpCst, "重み表")
'主処理-------------------------------
Call k0CLC_rcs(tmpCst, 1, 1)
'書出・終了---------------------------
Call k0CLC_end("Sheet2", "A1", "B1")
End Sub
'-------------------------------------------------
'◆主処理
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long, _
ByVal in_Stt As Long _
)
c = c + 1
Dim in_Idx As Long
Dim rmnCnt As Long
Dim bufCst As Long
Dim bufStr As String
Dim i As Long
With dicAry(outIdx)
If .Exists(memStr) Then
If tmpCst >= .Item(memStr) Then
Exit Sub
Else
.Item(memStr) = tmpCst
End If
Else
.Add memStr, tmpCst
End If
End With
bufStr = memStr
If outDsk(outIdx, 0) > outDsk(outIdx - 1, 0) Then
in_Stt = 1
End If
For i = in_Stt To in_Cnt
in_Idx = dstTbl(outIdx, i)
rmnCnt = in_Ary(in_Idx, 1)
If rmnCnt > 0 Then
tmpAry(in_Idx, rmnCnt) = outIdx
in_Ary(in_Idx, 1) = rmnCnt - 1
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
If outIdx < movCnt Then
Mid(memStr, rvsAry(in_Idx, rmnCnt), 1) = 1
Call k0CLC_rcs(bufCst, outIdx + 1, i)
memStr = bufStr
Else
Call k0CLC_nrc(bufCst)
in_Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
Exit For
End If
End If
in_Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
End If
Next i
End Sub
'-------------------------------------------------
'◆暫定ベスト更新
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
End Sub
'-------------------------------------------------
'◆予備処理
Private Sub k0CLC_pre( _
ByRef tmpCst As Long, ByRef tblNme As String)
'宣言---------------------------------
Dim WSF As WorksheetFunction
Dim outTmp As Variant
Dim in_Tmp As Variant
Dim tmpRow As Variant
Dim minCst As Long
Dim i As Long
Dim j As Long
Dim k As Long
Set WSF = Application.WorksheetFunction
'配列準備-----------------------------
ReDim outTmp(1 To movCnt)
ReDim in_Tmp(1 To movCnt)
With WSF
For i = 1 To movCnt
outTmp(i) = t01(i) + i / (movCnt + 1)
in_Tmp(i) = t02(i) + i / (movCnt + 1)
Next i
For i = 1 To movCnt
'◆out
outDsk(i, 3) = .Match(.Small(outTmp, i), outTmp, 0)
outDsk(i, 0) = Int(outTmp(outDsk(i, 3)))
If outDsk(i, 0) <> outDsk(i - 1, 0) Then
outCnt = outCnt + 1
outAry(outCnt, 0) = outDsk(i, 0)
outAry(outCnt, 1) = 1
Else
outAry(outCnt, 1) = outAry(outCnt, 1) + 1
End If
outDsk(i, 1) = outCnt
outDsk(i, 2) = outAry(outCnt, 1)
'◆in
in_Dsk(i, 3) = .Match(.Small(in_Tmp, i), in_Tmp, 0)
in_Dsk(i, 0) = Int(in_Tmp(in_Dsk(i, 3)))
If in_Dsk(i, 0) <> in_Dsk(i - 1, 0) Then
in_Cnt = in_Cnt + 1
in_Ary(in_Cnt, 0) = in_Dsk(i, 0)
in_Ary(in_Cnt, 1) = 1
Else
in_Ary(in_Cnt, 1) = in_Ary(in_Cnt, 1) + 1
End If
in_Dsk(i, 1) = in_Cnt
in_Dsk(i, 2) = in_Ary(in_Cnt, 1)
Next i
End With
'コストテーブル読み込み---------------
With Range(tblNme)
ReDim cstTbl(1 To movCnt, 1 To in_Cnt)
For i = 1 To movCnt
For j = 1 To in_Cnt
cstTbl(i, j) = _
.Cells(outDsk(i, 0), in_Ary(j, 0)).Value
Next j
Next i
ReDim pssAry(.Rows.Count, in_Cnt)
End With
'距離テーブル-------------------------
For i = 1 To movCnt
dstTbl(i, 0) = outDsk(i, 0)
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To in_Cnt
tmpRow(j) = tmpRow(j) + j / (in_Cnt + 1)
Next j
For j = 1 To in_Cnt
dstTbl(i, j) = _
WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
'初期暫定ベスト-----------------------
i = 0
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
i = i + 1
bstCst = bstCst + cstTbl(i, j)
rtnAry(j, k) = i
Next k
Next j
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
'最低コスト---------------------------
For i = 1 To movCnt
minCst = cstTbl(i, dstTbl(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To in_Cnt
cstTbl(i, dstTbl(i, j)) = _
cstTbl(i, dstTbl(i, j)) - minCst
Next j
Next i
'メモ---------------------------------
ReDim dicAry(1 To movCnt)
For i = 1 To movCnt
Set dicAry(i) = New Scripting.Dictionary
rvsAry(in_Dsk(i, 1), in_Dsk(i, 2)) = i
Next i
End Sub
'-------------------------------------------------
'◆書出・終了処理
Private Sub k0CLC_end( _
ByRef shtNme As String, _
ByRef outAds As String, _
ByRef in_Ads As String)
Dim i As Long
Dim j As Long
Dim k As Long
'結果書出-----------------------------
Application.ScreenUpdating = False
With Sheets(shtNme)
For i = 1 To movCnt
.Range(outAds).Cells(outDsk(i, 3), 1) = outDsk(i, 0)
Next i
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
.Range(in_Ads).Cells(outDsk(rtnAry(j, k), 3), 1) = in_Ary(j, 0)
ttt(rtnAry(j, k)) = in_Ary(j, 0)
Next k
Next j
End With
min = bstCst
'終了処理-----------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, rtnAry, dicAry, rvsAry
End Sub
'-----------------------------------------------------------
-
2012/09/26 (Wed) 18:16:58
_Kyle(1291004) - (08) いつか来た道
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(08) いつか来た道
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14770732
'
'「空き部屋の状態によって必要な労力が決まる」
'というハナシ。
'
'
'部屋数18，要素20対で10回テストして
' 最短 164msec.
' 最長 2,260msec.
'
'-----------------------------------------------------------
'-------------------------------------------------
'◆元質設定
Dim t01(100) As Integer '事前設定
Dim t02(100) As Integer '事前設定
Dim ttt(100) As Integer '結果
Dim min As Integer '結果
'-------------------------------------------------
'◆宣言
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const movLmt As Long = 100 '移動数上限
Private Const romLmt As Long = 20 '部屋数上限
Private cstTbl() As Long
Private dstTbl(movLmt, movLmt) As Long
Private outDsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private outAry(romLmt, 1) As Long
Private in_Dsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private in_Ary(romLmt, 1) As Long
Private tmpAry(romLmt, movLmt) As Long
Private rvsAry(romLmt, movLmt) As Long
Private rtnAry() As Long
Private dicAry() As Object
Private movCnt As Long
Private outCnt As Long
Private in_Cnt As Long
Private bstCst As Long
Private memStr As String
Private t As Long
Private c As Long
'-------------------------------------------------
'◆起動処理
Sub k0CLC_t08()
Dim 移動数 As Integer
Dim i As Long
Erase t01, t02, ttt
'↓ココは事前に入ってる要件
With Range("課題表")
移動数 = 0
For i = 1 To .Rows.Count
t01(i) = .Cells(i, 1).Value
t02(i) = .Cells(i, 2).Value
If t01(i) = 0 Then Exit For
移動数 = 移動数 + 1
Next i
End With
c = 0
t = timeGetTime
Call k0CLC(移動数)
Debug.Print "t08", timeGetTime - t, c, bstCst, movCnt
End Sub
'-------------------------------------------------
'◆親Ｐ
Private Sub k0CLC(ByRef 移動数 As Integer)
'宣言---------------------------------
Dim tmpCst As Long
'初期化-------------------------------
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, dicAry, rvsAry
ReDim rtnAry(movLmt, movLmt)
movCnt = 移動数
memStr = String$(movCnt, "0")
bstCst = 0
outCnt = 0
in_Cnt = 0
'予備処理-----------------------------
Call k0CLC_pre(tmpCst, "重み表")
'主処理-------------------------------
Call k0CLC_rcs(tmpCst, 1, 1)
'書出・終了---------------------------
Call k0CLC_end("Sheet2", "A1", "B1")
End Sub
'-------------------------------------------------
'◆主処理
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long, _
ByVal in_Stt As Long _
)
c = c + 1
Dim in_Idx As Long
Dim rmnCnt As Long
Dim bufCst As Long
Dim bufStr As String
Dim i As Long
With dicAry(outIdx)
If .Exists(memStr) Then
If tmpCst >= .Item(memStr) Then
Exit Sub
Else
.Remove memStr
End If
End If
End With
bufStr = memStr
If outDsk(outIdx, 0) > outDsk(outIdx - 1, 0) Then
in_Stt = 1
End If
For i = in_Stt To in_Cnt
in_Idx = dstTbl(outIdx, i)
rmnCnt = in_Ary(in_Idx, 1)
If rmnCnt > 0 Then
tmpAry(in_Idx, rmnCnt) = outIdx
in_Ary(in_Idx, 1) = rmnCnt - 1
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
If outIdx < movCnt Then
Mid(memStr, rvsAry(in_Idx, rmnCnt), 1) = 1
Call k0CLC_rcs(bufCst, outIdx + 1, i)
memStr = bufStr
Else
Call k0CLC_nrc(bufCst)
in_Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
Exit For
End If
End If
in_Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
End If
Next i
dicAry(outIdx).Add memStr, tmpCst
End Sub
'-------------------------------------------------
'◆暫定ベスト更新
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
End Sub
'-------------------------------------------------
'◆予備処理
Private Sub k0CLC_pre( _
ByRef tmpCst As Long, ByRef tblNme As String)
'宣言---------------------------------
Dim WSF As WorksheetFunction
Dim outTmp As Variant
Dim in_Tmp As Variant
Dim tmpRow As Variant
Dim minCst As Long
Dim i As Long
Dim j As Long
Dim k As Long
Set WSF = Application.WorksheetFunction
'配列準備-----------------------------
ReDim outTmp(1 To movCnt)
ReDim in_Tmp(1 To movCnt)
With WSF
For i = 1 To movCnt
outTmp(i) = t01(i) + i / (movCnt + 1)
in_Tmp(i) = t02(i) + i / (movCnt + 1)
Next i
For i = 1 To movCnt
'◆out
outDsk(i, 3) = .Match(.Small(outTmp, i), outTmp, 0)
outDsk(i, 0) = Int(outTmp(outDsk(i, 3)))
If outDsk(i, 0) <> outDsk(i - 1, 0) Then
outCnt = outCnt + 1
outAry(outCnt, 0) = outDsk(i, 0)
outAry(outCnt, 1) = 1
Else
outAry(outCnt, 1) = outAry(outCnt, 1) + 1
End If
outDsk(i, 1) = outCnt
outDsk(i, 2) = outAry(outCnt, 1)
'◆in
in_Dsk(i, 3) = .Match(.Small(in_Tmp, i), in_Tmp, 0)
in_Dsk(i, 0) = Int(in_Tmp(in_Dsk(i, 3)))
If in_Dsk(i, 0) <> in_Dsk(i - 1, 0) Then
in_Cnt = in_Cnt + 1
in_Ary(in_Cnt, 0) = in_Dsk(i, 0)
in_Ary(in_Cnt, 1) = 1
Else
in_Ary(in_Cnt, 1) = in_Ary(in_Cnt, 1) + 1
End If
in_Dsk(i, 1) = in_Cnt
in_Dsk(i, 2) = in_Ary(in_Cnt, 1)
Next i
End With
'コストテーブル読み込み---------------
With Range(tblNme)
ReDim cstTbl(1 To movCnt, 1 To in_Cnt)
For i = 1 To movCnt
For j = 1 To in_Cnt
cstTbl(i, j) = _
.Cells(outDsk(i, 0), in_Ary(j, 0)).Value
Next j
Next i
ReDim pssAry(.Rows.Count, in_Cnt)
End With
'距離テーブル-------------------------
For i = 1 To movCnt
dstTbl(i, 0) = outDsk(i, 0)
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To in_Cnt
tmpRow(j) = tmpRow(j) + j / (in_Cnt + 1)
Next j
For j = 1 To in_Cnt
dstTbl(i, j) = _
WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
'初期暫定ベスト-----------------------
i = 0
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
i = i + 1
bstCst = bstCst + cstTbl(i, j)
rtnAry(j, k) = i
Next k
Next j
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
'最低コスト---------------------------
For i = 1 To movCnt
minCst = cstTbl(i, dstTbl(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To in_Cnt
cstTbl(i, dstTbl(i, j)) = _
cstTbl(i, dstTbl(i, j)) - minCst
Next j
Next i
'メモ---------------------------------
ReDim dicAry(1 To movCnt)
For i = 1 To movCnt
Set dicAry(i) = CreateObject("Scripting.Dictionary")
rvsAry(in_Dsk(i, 1), in_Dsk(i, 2)) = i
Next i
End Sub
'-------------------------------------------------
'◆書出・終了処理
Private Sub k0CLC_end( _
ByRef shtNme As String, _
ByRef outAds As String, _
ByRef in_Ads As String)
Dim i As Long
Dim j As Long
Dim k As Long
'結果書出-----------------------------
Application.ScreenUpdating = False
With Sheets(shtNme)
For i = 1 To movCnt
.Range(outAds).Cells(outDsk(i, 3), 1) = outDsk(i, 0)
Next i
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
.Range(in_Ads).Cells(outDsk(rtnAry(j, k), 3), 1) = in_Ary(j, 0)
ttt(rtnAry(j, k)) = in_Ary(j, 0)
Next k
Next j
End With
min = bstCst
'終了処理-----------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, rtnAry, dicAry, rvsAry
End Sub
'-----------------------------------------------------------
-
2012/09/25 (Tue) 06:46:41
_Kyle(1291004) - (07) りふぁくたりんぐ？
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(07) りふぁくたりんぐ？
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14739912
'
'かえって饂飩になった。 orz
'
'でも速くなった。 ＼(^o^)／
'
'部屋数18，要素20対で10回テストして
' 最短 40msec.
' 最長 326,667msec.（５分半）
'
'-----------------------------------------------------------
'-------------------------------------------------
'◆元質設定
Dim t01(100) As Integer '事前設定
Dim t02(100) As Integer '事前設定
Dim ttt(100) As Integer '結果
Dim min As Integer '結果
'-------------------------------------------------
'◆宣言
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const movLmt As Long = 100 '移動数上限
Private Const romLmt As Long = 20 '部屋数上限
Private cstTbl() As Long
Private dstTbl(movLmt, movLmt) As Long
Private outDsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private outAry(romLmt, 1) As Long
Private in_Dsk(movLmt, 3) As Long 'No,Idx,Cnt,Row
Private in_Ary(romLmt, 1) As Long
Private tmpAry(romLmt, movLmt) As Long
Private rtnAry() As Long
Private movCnt As Long
Private outCnt As Long
Private in_Cnt As Long
Private bstCst As Long
Private t As Long
Private c As Long
'-------------------------------------------------
'◆起動処理
Sub k0CLC_t07()
Dim 移動数 As Integer
Dim i As Long
Erase t01, t02, ttt
'↓ココは事前に入ってる要件
With Range("課題表")
移動数 = 0
For i = 1 To .Rows.Count
t01(i) = .Cells(i, 1).Value
t02(i) = .Cells(i, 2).Value
If t01(i) = 0 Then Exit For
移動数 = 移動数 + 1
Next i
End With
c = 0
t = timeGetTime
Call k0CLC(移動数)
Debug.Print "t07", timeGetTime - t, c, bstCst, movCnt
End Sub
'-------------------------------------------------
'◆親Ｐ
Private Sub k0CLC(ByRef 移動数 As Integer)
'宣言---------------------------------
Dim tmpCst As Long
'初期化-------------------------------
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry
ReDim rtnAry(movLmt, movLmt)
movCnt = 移動数
bstCst = 0
outCnt = 0
in_Cnt = 0
'予備処理-----------------------------
Call k0CLC_pre(tmpCst, "重み表")
'主処理-------------------------------
Call k0CLC_rcs(tmpCst, 1, 1)
'書出・終了---------------------------
Call k0CLC_end("Sheet2", "A1", "B1")
End Sub
'-------------------------------------------------
'◆主処理
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long, _
ByVal in_Stt As Long _
)
c = c + 1
Dim in_Idx As Long
Dim rmnCnt As Long
Dim bufCst As Long
Dim i As Long
If outDsk(outIdx, 0) > outDsk(outIdx - 1, 0) Then
in_Stt = 1
End If
For i = in_Stt To in_Cnt
in_Idx = dstTbl(outIdx, i)
rmnCnt = in_Ary(in_Idx, 1)
If rmnCnt > 0 Then
tmpAry(in_Idx, rmnCnt) = outIdx
in_Ary(in_Idx, 1) = rmnCnt - 1
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
If outIdx < movCnt Then
Call k0CLC_rcs(bufCst, outIdx + 1, i)
Else
Call k0CLC_nrc(bufCst)
End If
End If
in_Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
End If
Next i
End Sub
'-------------------------------------------------
'◆暫定ベスト更新
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
End Sub
'-------------------------------------------------
'◆予備処理
Private Sub k0CLC_pre( _
ByRef tmpCst As Long, ByRef tblNme As String)
'宣言---------------------------------
Dim WSF As WorksheetFunction
Dim outTmp As Variant
Dim in_Tmp As Variant
Dim tmpRow As Variant
Dim minCst As Long
Dim i As Long
Dim j As Long
Dim k As Long
Set WSF = Application.WorksheetFunction
'課題転記・ソート---------------------
ReDim outTmp(1 To movCnt)
ReDim in_Tmp(1 To movCnt)
With WSF
For i = 1 To movCnt
outTmp(i) = t01(i) + i / (movCnt + 1)
in_Tmp(i) = t02(i) + i / (movCnt + 1)
Next i
For i = 1 To movCnt
outDsk(i, 3) = .Match(.Small(outTmp, i), outTmp, 0)
outDsk(i, 0) = Int(outTmp(outDsk(i, 3)))
If outDsk(i, 0) <> outDsk(i - 1, 0) Then
outCnt = outCnt + 1
outAry(outCnt, 0) = outDsk(i, 0)
outAry(outCnt, 1) = 1
Else
outAry(outCnt, 1) = outAry(outCnt, 1) + 1
End If
outDsk(i, 1) = outCnt
outDsk(i, 2) = outAry(outCnt, 1)
in_Dsk(i, 3) = .Match(.Small(in_Tmp, i), in_Tmp, 0)
in_Dsk(i, 0) = Int(in_Tmp(in_Dsk(i, 3)))
If in_Dsk(i, 0) <> in_Dsk(i - 1, 0) Then
in_Cnt = in_Cnt + 1
in_Ary(in_Cnt, 0) = in_Dsk(i, 0)
in_Ary(in_Cnt, 1) = 1
Else
in_Ary(in_Cnt, 1) = in_Ary(in_Cnt, 1) + 1
End If
in_Dsk(i, 1) = in_Cnt
in_Dsk(i, 2) = in_Ary(in_Cnt, 1)
dstTbl(i, 0) = outDsk(i, 0)
Next i
End With
'コストテーブル読み込み---------------
With Range(tblNme)
ReDim cstTbl(1 To movCnt, 1 To in_Cnt)
For i = 1 To movCnt
For j = 1 To in_Cnt
cstTbl(i, j) = _
.Cells(outDsk(i, 0), in_Ary(j, 0)).Value
Next j
Next i
ReDim pssAry(.Rows.Count, in_Cnt)
End With
'距離テーブル-------------------------
For i = 1 To movCnt
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To in_Cnt
tmpRow(j) = tmpRow(j) + j / (in_Cnt + 1)
Next j
For j = 1 To in_Cnt
dstTbl(i, j) = _
WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
'初期暫定ベスト-----------------------
i = 0
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
i = i + 1
bstCst = bstCst + cstTbl(i, j)
rtnAry(j, k) = i
Next k
Next j
Application.StatusBar = "探索中 暫定ベスト： " & bstCst
'最低コスト---------------------------
For i = 1 To movCnt
minCst = cstTbl(i, dstTbl(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To in_Cnt
cstTbl(i, dstTbl(i, j)) = _
cstTbl(i, dstTbl(i, j)) - minCst
Next j
Next i
End Sub
'-------------------------------------------------
'◆書出・終了処理
Private Sub k0CLC_end( _
ByRef shtNme As String, _
ByRef outAds As String, _
ByRef in_Ads As String)
Dim i As Long
Dim j As Long
Dim k As Long
'結果書出-----------------------------
Application.ScreenUpdating = False
With Sheets(shtNme)
For i = 1 To movCnt
.Range(outAds).Cells(outDsk(i, 3), 1) = outDsk(i, 0)
Next i
For j = 1 To in_Cnt
For k = 1 To in_Ary(j, 1)
.Range(in_Ads).Cells(outDsk(rtnAry(j, k), 3), 1) = in_Ary(j, 0)
ttt(rtnAry(j, k)) = in_Ary(j, 0)
Next k
Next j
End With
min = bstCst
'終了処理-----------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, dstTbl, outDsk, in_Dsk, outAry, in_Ary, _
tmpAry, rtnAry
End Sub
'-----------------------------------------------------------
-
2012/09/22 (Sat) 22:52:40
_Kyle(1291004) - (06) どれを出しても一緒
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(06) どれを出しても一緒
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14731316
'
'同じ部屋から出すなら、どれを出しても一緒というハナシ
'
'部屋数18，要素20対で10回テストして
' 最短 610msec.
' 最長 5,622,867msec.
'
'-----------------------------------------------------------
'-------------------------------------------------
'◆元質設定
Dim t01(100) As Integer '事前設定
Dim t02(100) As Integer '事前設定
Dim ttt(100) As Integer '結果
Dim min As Integer '結果
'-------------------------------------------------
'◆宣言
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const maxCnt As Long = 100
Private cstTbl() As Long
Private outAry(maxCnt, maxCnt) As Long
Private in_Ary(maxCnt) As Long
Private in2Ary(maxCnt, 1) As Long
Private pssAry() As Boolean
Private tmpAry(maxCnt, maxCnt) As Long
Private rtnAry() As Long
Private itmCnt As Long
Private in_Cnt As Long
Private bstCst As Long
Private t As Long
Private c As Long
'-------------------------------------------------
'◆起動処理
Sub k0CLC_t06()
Dim 移動数 As Long
Dim i As Long
Erase t01, t02, ttt
With Range("tskRng")
'↓ココは事前に入ってる要件
移動数 = 0
For i = 1 To .Rows.Count
t01(i) = .Cells(i, 1).Value
t02(i) = .Cells(i, 2).Value
If t01(i) = 0 Then Exit For
移動数 = 移動数 + 1
Next i
c = 0
t = timeGetTime
Call k0CLC(移動数)
End With
Debug.Print "t06", timeGetTime - t, c, bstCst, itmCnt
End Sub
'-------------------------------------------------
'◆親Ｐ
Private Sub k0CLC(ByRef movCnt As Long)
'宣言---------------------------------
Dim WSF As WorksheetFunction
Dim tmpRow As Variant
Dim minCst As Long
Dim tmpCst As Long
Dim newFlg As Boolean
Dim i As Long
Dim j As Long
Dim k As Long
'初期化-------------------------------
itmCnt = movCnt
bstCst = 0
in_Cnt = 0
Erase cstTbl, outAry, in_Ary, tmpAry, in2Ary
ReDim rtnAry(maxCnt, maxCnt)
Set WSF = Application.WorksheetFunction
'課題転記-----------------------------
For i = 1 To itmCnt
outAry(i, 0) = t01(i)
in_Ary(i) = t02(i)
Next i
'in2Ary-------------------------------
' ※超やっつけ 要りふぁくたりんぐ
For i = 1 To itmCnt
newFlg = True
For j = 1 To in_Cnt
If in2Ary(j, 0) = in_Ary(i) Then
in2Ary(j, 1) = in2Ary(j, 1) + 1
newFlg = False
Exit For
End If
Next j
If newFlg Then
in_Cnt = in_Cnt + 1
in2Ary(in_Cnt, 0) = in_Ary(i)
in2Ary(in_Cnt, 1) = 1
End If
Next i
'コストテーブル読み込み---------------
With Range("重み表")
ReDim cstTbl(1 To itmCnt, 1 To in_Cnt)
For i = 1 To itmCnt
For j = 1 To in_Cnt
cstTbl(i, j) = _
.Cells(outAry(i, 0), in2Ary(j, 0)).Value
Next j
Next i
ReDim pssAry(.Rows.Count, in_Cnt)
End With
'ソートテーブル-----------------------
' ※超やっつけ。要りふぁくたりんぐ
For i = 1 To itmCnt
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To in_Cnt
tmpRow(j) = tmpRow(j) + j / (in_Cnt + 1)
Next j
For j = 1 To in_Cnt
outAry(i, j) = _
WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
'初期暫定ベスト-----------------------
i = 0
For j = 1 To in_Cnt
For k = 1 To in2Ary(j, 1)
i = i + 1
bstCst = bstCst + cstTbl(i, j)
rtnAry(j, k) = i
Next k
Next j
Application.StatusBar = bstCst
'最低コスト---------------------------
For i = 1 To itmCnt
minCst = cstTbl(i, outAry(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To in_Cnt
cstTbl(i, outAry(i, j)) = _
cstTbl(i, outAry(i, j)) - minCst
Next j
Next i
'主処理呼出---------------------------
Call k0CLC_rcs(tmpCst, 1)
'結果書出-----------------------------
Application.ScreenUpdating = False
For i = 1 To itmCnt
Sheets("Sheet2").Cells(i, 1) = outAry(i, 0)
Next i
For j = 1 To in_Cnt
For k = 1 To in2Ary(j, 1)
Sheets("Sheet2").Cells(rtnAry(j, k), 2) = in2Ary(j, 0)
ttt(rtnAry(j, k)) = in2Ary(j, 0)
Next k
Next j
min = bstCst
'終了処理-----------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, outAry, in_Ary, tmpAry, rtnAry, in2Ary, pssAry
End Sub
'-------------------------------------------------
'◆主処理
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long _
)
c = c + 1
Dim in_Idx As Long
Dim rmnCnt As Long
Dim bufCst As Long
Dim bufAry() As Boolean
Dim i As Long
bufAry = pssAry
For i = 1 To in_Cnt
in_Idx = outAry(outIdx, i)
If Not pssAry(outAry(outIdx, 0), in_Idx) Then
rmnCnt = in2Ary(in_Idx, 1)
If rmnCnt > 0 Then
tmpAry(in_Idx, rmnCnt) = outIdx
in2Ary(in_Idx, 1) = rmnCnt - 1
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
If outIdx < itmCnt Then
Call k0CLC_rcs(bufCst, outIdx + 1)
Else
Call k0CLC_nrc(bufCst)
End If
End If
in2Ary(in_Idx, 1) = rmnCnt
tmpAry(in_Idx, rmnCnt) = 0
End If
End If
pssAry(outAry(outIdx, 0), in_Idx) = True
Next i
pssAry = bufAry
End Sub
'-------------------------------------------------
'◆暫定ベスト更新
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = bstCst
End Sub
'-----------------------------------------------------------
-
2012/09/22 (Sat) 07:07:23
_Kyle(1291004) - (05) どこに置いても一緒
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(05) どこに置いても一緒
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14726531
'同じ部屋に入れるなら、どこに置いても一緒というハナシ
'
'饂飩な感じになっちゃいましたが、時間があったら直します。
'
'あと、動作仕様を元質に整合させました。
'-----------------------------------------------------------
'-------------------------------------------------
'◆元質設定
Dim t01(100) As Integer '事前設定
Dim t02(100) As Integer '事前設定
Dim ttt(100) As Integer '結果
Dim min As Integer '結果
'-------------------------------------------------
'◆宣言
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const maxCnt As Long = 100
Private cstTbl() As Long
Private outAry(maxCnt, maxCnt) As Long
Private in_Ary(maxCnt) As Long
Private in2Ary(maxCnt, 1) As Long
Private tmpAry(maxCnt, maxCnt) As Long
Private rtnAry() As Long
Private itmCnt As Long
Private in_Cnt As Long
Private bstCst As Long
Private t As Long
Private c As Long
'-------------------------------------------------
'◆起動処理
Sub k0CLC_t05()
Dim 移動数 As Long
Dim i As Long
Erase t01, t02, ttt
With Range("tskRng")
'↓ココは事前に入ってる要件
移動数 = 0
For i = 1 To .Rows.Count
t01(i) = .Cells(i, 1).Value
t02(i) = .Cells(i, 2).Value
If t01(i) = 0 Then Exit For
移動数 = 移動数 + 1
Next i
c = 0
t = timeGetTime
Call k0CLC(移動数)
End With
Debug.Print "t05", timeGetTime - t, c, bstCst, itmCnt
End Sub
'-------------------------------------------------
'◆親Ｐ
Private Sub k0CLC(ByRef movCnt As Long)
'宣言---------------------------------
Dim WSF As WorksheetFunction
Dim tmpRow As Variant
Dim minCst As Long
Dim tmpCst As Long
Dim newFlg As Boolean
Dim i As Long
Dim j As Long
Dim k As Long
'初期化-------------------------------
itmCnt = movCnt
bstCst = 0
in_Cnt = 0
Erase cstTbl, outAry, in_Ary, tmpAry, in2Ary
ReDim rtnAry(maxCnt, maxCnt)
Set WSF = Application.WorksheetFunction
'課題転記-----------------------------
For i = 1 To itmCnt
outAry(i, 0) = t01(i)
in_Ary(i) = t02(i)
Next i
'in2Ary-------------------------------
' ※超やっつけ 要りふぁくたりんぐ
For i = 1 To itmCnt
newFlg = True
For j = 1 To in_Cnt
If in2Ary(j, 0) = in_Ary(i) Then
in2Ary(j, 1) = in2Ary(j, 1) + 1
newFlg = False
Exit For
End If
Next j
If newFlg Then
in_Cnt = in_Cnt + 1
in2Ary(in_Cnt, 0) = in_Ary(i)
in2Ary(in_Cnt, 1) = 1
End If
Next i
'コストテーブル読み込み---------------
With Range("重み表")
ReDim cstTbl(1 To itmCnt, 1 To in_Cnt)
For i = 1 To itmCnt
For j = 1 To in_Cnt
cstTbl(i, j) = _
.Cells(outAry(i, 0), in2Ary(j, 0)).Value
Next j
Next i
End With
'ソートテーブル-----------------------
' ※超やっつけ。要りふぁくたりんぐ
For i = 1 To itmCnt
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To in_Cnt
tmpRow(j) = tmpRow(j) + j / (in_Cnt + 1)
Next j
For j = 1 To in_Cnt
outAry(i, j) = _
WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
'初期暫定ベスト-----------------------
i = 0
For j = 1 To in_Cnt
For k = 1 To in2Ary(j, 1)
i = i + 1
bstCst = bstCst + cstTbl(i, j)
rtnAry(j, k) = i
Next k
Next j
Application.StatusBar = bstCst
'最低コスト---------------------------
For i = 1 To itmCnt
minCst = cstTbl(i, outAry(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To in_Cnt
cstTbl(i, outAry(i, j)) = _
cstTbl(i, outAry(i, j)) - minCst
Next j
Next i
'主処理呼出---------------------------
Call k0CLC_rcs(tmpCst, 1)
'結果書出-----------------------------
Application.ScreenUpdating = False
For i = 1 To itmCnt
Sheets("Sheet2").Cells(i, 1) = outAry(i, 0)
Next i
For j = 1 To in_Cnt
For k = 1 To in2Ary(j, 1)
Sheets("Sheet2").Cells(rtnAry(j, k), 2) = in2Ary(j, 0)
ttt(rtnAry(j, k)) = in2Ary(j, 0)
Next k
Next j
min = bstCst
'終了処理-----------------------------
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, outAry, in_Ary, tmpAry, rtnAry, in2Ary
End Sub
'-------------------------------------------------
'◆主処理
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long _
)
c = c + 1
Dim in_Idx As Long
Dim bufCst As Long
Dim i As Long
For i = 1 To in_Cnt
in_Idx = outAry(outIdx, i)
If in2Ary(in_Idx, 1) > 0 Then
tmpAry(in_Idx, in2Ary(in_Idx, 1)) = outIdx
in2Ary(in_Idx, 1) = in2Ary(in_Idx, 1) - 1
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
If outIdx < itmCnt Then
Call k0CLC_rcs(bufCst, outIdx + 1)
Else
Call k0CLC_nrc(bufCst)
End If
End If
in2Ary(in_Idx, 1) = in2Ary(in_Idx, 1) + 1
tmpAry(in_Idx, in2Ary(in_Idx, 1)) = 0
End If
Next i
End Sub
'-------------------------------------------------
'◆暫定ベスト更新
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = bstCst
End Sub
'-----------------------------------------------------------
-
2012/09/21 (Fri) 20:47:04
_Kyle(1291004) - (04) 近い場所から試す＋１
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(04) 近い場所から試す＋１
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14725574
'・近い部屋から試す
'・最小コストを事前に積んでおく
'・変数名・プロシージャ名変更
'-----------------------------------------------------------
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const maxCnt As Long = 100
Private cstTbl() As Long
Private outAry(maxCnt, maxCnt) As Long
Private in_Ary(maxCnt) As Long
Private tmpAry(maxCnt) As Long
Private rtnAry() As Long
Private itmCnt As Long
Private bstCst As Long
Private t As Long
Private c As Long
'-------------------------------------------------
Sub k0CLC_t04()
Dim i As Long
With Range("tskRng")
'↓ココは事前に入ってる要件
itmCnt = 0
For i = 1 To .Rows.Count
outAry(i, 0) = .Cells(i, 1).Value
in_Ary(i) = .Cells(i, 2).Value
If outAry(i, 0) = 0 Then Exit For
itmCnt = itmCnt + 1
Next i
c = 0
t = timeGetTime
Call k0CLC
End With
Debug.Print "t04", timeGetTime - t, c, bstCst, itmCnt
End Sub
'-------------------------------------------------
Private Sub k0CLC()
Dim WSF As WorksheetFunction
Dim tmpRow As Variant
Dim minCst As Long
Dim tmpCst As Long
Dim i As Long
Dim j As Long
bstCst = 0
Erase tmpAry
ReDim rtnAry(maxCnt)
Set WSF = Application.WorksheetFunction
'コストテーブル
With Range("重み表")
ReDim cstTbl(1 To itmCnt, 1 To itmCnt)
For i = 1 To itmCnt
For j = 1 To itmCnt
cstTbl(i, j) = .Cells(outAry(i, 0), in_Ary(j)).Value
Next j
Next i
End With
'ソートテーブル
' ※超やっつけ。要 りふぁくたりんぐ
For i = 1 To itmCnt
tmpRow = WSF.Index(cstTbl, i)
For j = 1 To itmCnt
tmpRow(j) = tmpRow(j) + j / (itmCnt + 1)
Next j
For j = 1 To itmCnt
outAry(i, j) = WSF.Match(WSF.Small(tmpRow, j), tmpRow, 0)
Next j
Next i
For i = 1 To itmCnt
bstCst = bstCst + cstTbl(i, i)
rtnAry(i) = i
Next i
Application.StatusBar = bstCst
'最低コスト
For i = 1 To itmCnt
minCst = cstTbl(i, outAry(i, 1))
tmpCst = tmpCst + minCst
For j = 1 To itmCnt
cstTbl(i, outAry(i, j)) = cstTbl(i, outAry(i, j)) - minCst
Next j
Next i
Call k0CLC_rcs(tmpCst, 1)
Application.ScreenUpdating = False
For i = 1 To itmCnt
Sheets("Sheet2").Cells(i, 1) = outAry(i, 0)
Sheets("Sheet2").Cells(rtnAry(i), 2) = in_Ary(i)
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, outAry, in_Ary, tmpAry, rtnAry
End Sub
'-------------------------------------------------
Private Sub k0CLC_rcs( _
ByVal tmpCst As Long, _
ByVal outIdx As Long _
)
c = c + 1
Dim in_Idx As Long
Dim bufCst As Long
Dim i As Long
For i = 1 To itmCnt
in_Idx = outAry(outIdx, i)
If tmpAry(in_Idx) = 0 Then
tmpAry(in_Idx) = outIdx
bufCst = tmpCst + cstTbl(outIdx, in_Idx)
If bufCst < bstCst Then
If outIdx < itmCnt Then
Call k0CLC_rcs(bufCst, outIdx + 1)
Else
Call k0CLC_nrc(bufCst)
End If
End If
tmpAry(in_Idx) = 0
End If
Next i
End Sub
'-------------------------------------------------
Private Sub k0CLC_nrc(ByVal tmpCst As Long)
rtnAry = tmpAry
bstCst = tmpCst
Application.StatusBar = bstCst
End Sub
'-----------------------------------------------------------
-
2012/09/21 (Fri) 00:36:37
_Kyle(1291004) - (03) 暫定ベスト判定
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(03) 暫定ベスト判定
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14708866
'ある時点の労力が、暫定ベストの労力を超えてしまったら
'その後どう選んでも無駄というハナシ
'
'所要時間 元コード比 0.32【パーセント】
'-----------------------------------------------------------
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const maxCnt As Long = 100
Private cstTbl() As Long
Private outAry(maxCnt) As Long
Private in_Ary(maxCnt) As Long
Private tmpAry(maxCnt) As Long
Private rtnAry() As Long
Private itmCnt As Long
Private minCst As Long
Private t As Long
Private c As Long
'-------------------------------------------------
Sub k0CLC_t03()
Dim i As Long
With Range("tskRng")
'↓ココは事前に入ってる要件
itmCnt = 0
For i = 1 To .Rows.Count
outAry(i) = .Cells(i, 1).Value
in_Ary(i) = .Cells(i, 2).Value
If outAry(i) = 0 Then Exit For
itmCnt = itmCnt + 1
Next i
c = 0
t = timeGetTime
Call k0CLC
End With
Debug.Print "t03", timeGetTime - t, c, minCst
End Sub
'-------------------------------------------------
Private Sub k0CLC()
Dim i As Long
Dim j As Long
With Range("重み表")
ReDim cstTbl(.Rows.Count, .Columns.Count)
For i = 1 To itmCnt
For j = 1 To itmCnt
cstTbl(i, j) = .Cells(outAry(i), in_Ary(j)).Value
Next j
Next i
End With
minCst = 0
Erase tmpAry
ReDim rtnAry(maxCnt)
For i = 1 To itmCnt
minCst = minCst + cstTbl(i, i)
rtnAry(i) = i
Next i
Application.StatusBar = minCst
Call k0CLC_r(0, 1)
Application.ScreenUpdating = False
For i = 1 To itmCnt
Sheets("Sheet2").Cells(i, 1) = outAry(i)
Sheets("Sheet2").Cells(rtnAry(i), 2) = in_Ary(i)
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, outAry, in_Ary, tmpAry, rtnAry
End Sub
'-------------------------------------------------
Private Sub k0CLC_r( _
ByVal tmpCst As Long, _
ByVal outIdx As Long _
)
c = c + 1
Dim bufCst As Long
Dim i As Long
For i = 1 To itmCnt
If tmpAry(i) = 0 Then
tmpAry(i) = outIdx
bufCst = tmpCst + cstTbl(outIdx, i)
If bufCst < minCst Then
If outIdx < itmCnt Then
Call k0CLC_r(bufCst, outIdx + 1)
Else
Call k0CLC_c(bufCst)
End If
End If
tmpAry(i) = 0
End If
Next i
End Sub
'-------------------------------------------------
Private Sub k0CLC_c(ByVal tmpCst As Long)
rtnAry = tmpAry
minCst = tmpCst
Application.StatusBar = minCst
End Sub
'-----------------------------------------------------------
-
2012/09/20 (Thu) 06:57:28
_Kyle(1291004) - (02) ざっくり直す
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(02) ざっくり直す
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14706900
'とりあえず目に付いたところを
'ざっくり直してみました。
'
'再帰回数は元コード 及び t01と変わらずですが
'所要時間は元コード比96%減，t01比90%減です。
'
'でも、モジュールレベル変数並べてるので
'きっと怒られますね(^^;;;;
'
'itmCntの出し方は我ながら冗長ですが、
'この数字は事前に出てる条件なのでてきとーに。
'
't03以降、ココから刈っていきます。
'-----------------------------------------------------------
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Const maxCnt As Long = 100
Private cstTbl() As Long
Private outAry(maxCnt) As Long
Private in_Ary(maxCnt) As Long
Private tmpAry(maxCnt) As Long
Private rtnAry() As Long
Private itmCnt As Long
Private minCst As Long
Private t As Long
Private c As Long
'-------------------------------------------------
Sub k0CLC_t02()
Dim i As Long
With Range("tskRng")
itmCnt = 0
'↓ココは事前に入ってる要件
For i = 1 To .Rows.Count
outAry(i) = .Cells(i, 1).Value
in_Ary(i) = .Cells(i, 2).Value
If outAry(i) = 0 Then Exit For
itmCnt = itmCnt + 1
Next i
c = 0
t = timeGetTime
Call k0CLC
End With
Debug.Print "t02", timeGetTime - t, c, minCst
End Sub
'-------------------------------------------------
Private Sub k0CLC()
Dim i As Long
Dim j As Long
With Range("重み表")
ReDim cstTbl(.Rows.Count, .Columns.Count)
For i = 1 To itmCnt
For j = 1 To itmCnt
cstTbl(i, j) = .Cells(outAry(i), in_Ary(j)).Value
Next j
Next i
End With
minCst = 0
Erase tmpAry
ReDim rtnAry(maxCnt)
For i = 1 To itmCnt
minCst = minCst + cstTbl(i, i)
rtnAry(i) = i
Next i
Application.StatusBar = minCst
Call k0CLC_r(0, 1)
For i = 1 To itmCnt
Sheets("Sheet2").Cells(i, 1) = outAry(i)
Sheets("Sheet2").Cells(rtnAry(i), 2) = in_Ary(i)
Next i
Application.StatusBar = False
Application.ScreenUpdating = True
Erase cstTbl, outAry, in_Ary, tmpAry, rtnAry
End Sub
'-------------------------------------------------
Private Sub k0CLC_r( _
ByVal tmpCst As Long, _
ByVal outIdx As Long _
)
c = c + 1
Dim bufCst As Long
Dim i As Long
For i = 1 To itmCnt
If tmpAry(i) = 0 Then
tmpAry(i) = outIdx
bufCst = tmpCst + cstTbl(outIdx, i)
If outIdx < itmCnt Then
Call k0CLC_r(bufCst, outIdx + 1)
ElseIf bufCst < minCst Then
Call k0CLC_c(bufCst)
End If
tmpAry(i) = 0
End If
Next i
End Sub
'-------------------------------------------------
Private Sub k0CLC_c(ByVal tmpCst As Long)
rtnAry = tmpAry
minCst = tmpCst
Application.StatusBar = minCst
End Sub
'-----------------------------------------------------------
-
2012/09/20 (Thu) 00:42:57
_Kyle(1291004) - (01) 叩き台
-
URL /
Comment
'-----------------------------------------------------------
'■qa7697154 ：(01) 叩き台
'abyssinia.bbs.fc2.com/ act=reply&tid=6924349#14706170
'叩き台です。
'
'◆変更点
' ・起動マクロ(test)設置
' ・変数名と型変更
' ・レイアウト変更
' ・タイムカウンタ・再帰カウンタ設置
'
'再帰数は変わらずですが、
'子Ｐのカウンタを宣言したので
'所要時間半減してます。
'-----------------------------------------------------------
Declare Function timeGetTime Lib "winmm.dll" () As Long
Private cstTbl As Variant
Private outAry(100) As Long
Private in_Ary(100) As Long
Private rtnAry(100) As Long
Private minCst As Long
Private t As Long
Private c As Long
'-------------------------------------------------
Sub k0CLC_t01()
Dim i As Long
With Range("tskRng")
For i = 1 To .Rows.Count
outAry(i) = .Cells(i, 1).Value
in_Ary(i) = .Cells(i, 2).Value
Next i
c = 0
t = timeGetTime
Call k0CLC(.Rows.Count)
Debug.Print timeGetTime - t, c
End With
End Sub
'-------------------------------------------------
Sub k0CLC(itmCnt As Long)
Dim tmpAry(100) As Long
Dim i As Long
cstTbl = Range("重み表")
minCst = 0
For i = 1 To itmCnt
minCst = minCst + cstTbl(outAry(i), in_Ary(i))
rtnAry(i) = i
Next i
Call k0CLC_r(itmCnt, tmpAry, 1)
For i = 1 To itmCnt
Sheets("Sheet2").Cells(i, 1) = outAry(i)
Sheets("Sheet2").Cells(i, 2) = in_Ary(rtnAry(i))
Next i
End Sub
'-------------------------------------------------
Private Sub k0CLC_r( _
ByRef itmCnt As Long, _
ByRef tmpAry() As Long, _
ByRef itmIdx As Long _
)
c = c + 1
Dim tmpIdx As Long
Dim stdFlg As Boolean
Dim i As Long
Dim j As Long
For i = 1 To itmCnt
stdFlg = True
For j = 1 To itmIdx - 1
If tmpAry(j) = i Then
stdFlg = False
End If
Next
If stdFlg Then
tmpAry(itmIdx) = i
If itmIdx < itmCnt Then
tmpIdx = itmIdx
itmIdx = itmIdx + 1
Call k0CLC_r(itmCnt, tmpAry, itmIdx)
itmIdx = tmpIdx
Else
Call k0CLC_c(itmCnt, tmpAry)
End If
tmpAry(itmIdx) = False
End If
Next
End Sub
'-------------------------------------------------
Private Sub k0CLC_c(itmCnt As Long, tmpAry() As Long)
Dim tmpCst As Long
Dim i As Long
For i = 1 To itmCnt
tmpCst = tmpCst + cstTbl(outAry(i), in_Ary(tmpAry(i)))
Next
If minCst > tmpCst Then
minCst = tmpCst
For i = 1 To itmCnt
rtnAry(i) = tmpAry(i)
Next
End If
End Sub
'-----------------------------------------------------------