～ kiku tips ～　再帰処理にはまる（その２）

スポンサーサイト

上記の広告は１ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

TB： -- / CM： --

vAry = Array(0, 1.1, 4.4, 3.3, 2.2)　という配列があった時、
何組かの同じ配列を使って総当たりで、たし算しましょう。
その結果、重複する数値は排除して小さい順に表示しましょう。

例えば、
A = Array(0, 1.1, 4.4, 3.3, 2.2)
B = Array(0, 1.1, 4.4, 3.3, 2.2)
C = Array(0, 1.1, 4.4, 3.3, 2.2)
の３つを使って、
A(0)+B(0)+C(0)= や A(0)+B(0)+C(1)= や A(0)+B(0)+C(2)= ･････
A(0)+B(1)+C(0)= や A(0)+B(1)+C(1)= や A(0)+B(1)+C(2)= ･････
････
A(4)+B(3)+C(0)= や A(4)+B(3)+C(1)= や A(4)+B(3)+C(2)= ･････
A(4)+B(4)+C(0)= や A(4)+B(4)+C(1)= や A(4)+B(4)+C(2)= ･････
の結果、重複を排除して小さい順に
　0
　1.1
　2.2
　3.3
　4.4
　5.5
　6.6
　7.7
　8.8
　9.9
　11
　12.1
　13.2
と

サンプルファイルは　再帰処理にはまる（その１）　にあります
再帰処理にはまる（その３）も読んでいただければと

１）ベタで考える【標準モジュール：Pat2n】

１－１）総当たりの結果を格納する配列を用意する

まず、対象を配列で作成したら、計算誤差をなくすために CCur 変換しておきます。
何組使ってやるかは　iCount で指定するように

基本の配列を１組分作っておきます。
次の組を処理する際、全ての結果を格納できるように領域を確保して総当たり計算
これを必要な組分繰り返します。

その後、重複分の値を排除する為に　Dictionary　を使用します。
値をキーとして利用することで、重複を排除できます。
排除後のキーを取得して、昇順に並び変えて表示します。

Public Sub Sample1()
　　Dim vAry As Variant
　　Dim vBase As Variant
　　Dim vTmp As Variant
　　Dim dic As Object
　　Dim i As Long, jB As Long, jA As Long, k As Long

　　Const iCount As Long = 3

　　vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'　　vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

　　For i = 0 To UBound(vAry)
　　　　vAry(i) = CCur(vAry(i))
　　Next

　　vBase = vAry
　　For i = 2 To iCount
　　　　ReDim vTmp((UBound(vBase) + 1) * (UBound(vAry) + 1) - 1)
　　　　k = 0
　　　　For jB = 0 To UBound(vBase)
　　　　　　For jA = 0 To UBound(vAry)
　　　　　　　　vTmp(k) = vBase(jB) + vAry(jA)
　　　　　　　　k = k + 1
　　　　　　Next
　　　　Next
　　　　vBase = vTmp
　　　　vTmp = Empty
　　Next

　　Set dic = CreateObject("Scripting.Dictionary")
　　For i = 0 To UBound(vBase)
　　　　dic.Item(vBase(i)) = Null
　　Next
　　vBase = dic.keys
　　Set dic = Nothing

　　For i = 0 To UBound(vBase) - 1
　　　　For k = i + 1 To UBound(vBase)
　　　　　　If (vBase(k) < vBase(i)) Then
　　　　　　　　vTmp = vBase(i)
　　　　　　　　vBase(i) = vBase(k)
　　　　　　　　vBase(k) = vTmp
　　　　　　End If
　　　　Next
　　Next

　　For i = 0 To UBound(vBase)
　　　　Debug.Print vBase(i)
　　Next
End Sub

組数が多くなってくると、全計算結果を格納する領域の確保が問題になってくると思います。
そこで、２組目、３組目と処理をしていく中で、重複を排除した結果だけを覚えておきましょう。
その結果と、次の組を総当たりで･････この時も重複は排除しておきましょう。

それが次の例となります。

１－２）計算結果のみを Dictionary で管理

Public Sub Sample2()
　　Dim vAry As Variant
　　Dim vBase As Variant
　　Dim vTmp As Variant
　　Dim dic As Object
　　Dim i As Long, j As Long

　　Const iCount As Long = 3

　　vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'　　vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

　　Set dic = CreateObject("Scripting.Dictionary")

　　For i = 0 To UBound(vAry)
　　　　vAry(i) = CCur(vAry(i))
　　　　dic.Item(vAry(i)) = Null
　　Next

　　For i = 2 To iCount
　　　　vBase = dic.keys
　　　　dic.RemoveAll
　　　　For Each vTmp In vBase
　　　　　　For j = 0 To UBound(vAry)
　　　　　　　　dic.Item(vTmp + vAry(j)) = Null
　　　　　　Next
　　　　Next
　　Next
　　vBase = dic.keys
　　Set dic = Nothing

　　For i = 0 To UBound(vBase) - 1
　　　　For j = i + 1 To UBound(vBase)
　　　　　　If (vBase(j) < vBase(i)) Then
　　　　　　　　vTmp = vBase(i)
　　　　　　　　vBase(i) = vBase(j)
　　　　　　　　vBase(j) = vTmp
　　　　　　End If
　　　　Next
　　Next

　　For i = 0 To UBound(vBase)
　　　　Debug.Print vBase(i)
　　Next
End Sub

組数が多くなってくると、この方法が一番良いようです。

VBA記述での例にはなりませんが、せっかく Access を使っているので、
テーブルを用意して、クエリで直積を利用して･･･このクエリを作れるように
作られるクエリは

SELECT DISTINCT (Q1.値+Q2.値+Q3.値) AS 値
FROM T1 AS Q1, T1 AS Q2, T1 AS Q3;

てな感じになります。
また、クエリを手動/VBA で作成した時のプロパティの違いも確認したいかなっていうレベルで以下
（テーブルは「T1」として用意しています）

Public Sub DataMakeT1()
　　Dim vAry As Variant
　　Dim i As Long

　　vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'　　vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

　　For i = 0 To UBound(vAry)
　　　　vAry(i) = CCur(vAry(i))
　　Next

　　With CurrentDb
　　　　.Execute "DELETE * FROM T1;"
　　　　With .OpenRecordset("T1")
　　　　　　For i = 0 To UBound(vAry)
　　　　　　　　.AddNew
　　　　　　　　.Fields("値") = vAry(i)
　　　　　　　　.Update
　　　　　　Next
　　　　　　.Close
　　　　End With
　　End With
End Sub

Public Sub QueryMakeQ_T1()
　　Dim sSql As String
　　Dim sS As String
　　Dim i As Long

　　Const sQuery As String = "Q_T1"
　　Const iCount As Long = 3

　　sSql = ""
　　sS = ""
　　For i = 1 To iCount
　　　　sSql = sSql & "+Q" & i & ".値"
　　　　sS = sS & ", T1 AS Q" & i
　　Next
　　sSql = "(" & Mid(sSql, 2) & ") AS 値"
　　sS = Mid(sS, 3)

　　sSql = "SELECT DISTINCT " & sSql & " FROM " & sS & ";"

　　On Error Resume Next
　　DoCmd.Close acQuery, sQuery, acSaveNo
　　With CurrentDb
　　　　.QueryDefs.Delete sQuery
　　　　.CreateQueryDef sQuery, sSql
　　　　.QueryDefs.Refresh
　　　　With .QueryDefs(sQuery).Fields("値")
　　　　　　.Properties.Append .CreateProperty("Format", dbText, "General Number")
　　　　　　.Properties.Append .CreateProperty("DecimalPlaces", dbByte, 4)
　　　　End With
　　End With
　　DoCmd.OpenQuery sQuery
End Sub

Public Sub ChkPrp()
　　Dim prp As DAO.Property

　　Const sQuery As String = "Q_T1"

　　On Error Resume Next
　　With CurrentDb
　　　　With .QueryDefs(sQuery).Fields("値")
　　　　　　For Each prp In .Properties
　　　　　　　　Debug.Print prp.Name,
　　　　　　　　Debug.Print prp.Type,
　　　　　　　　Debug.Print prp.Value,
　　　　　　　　Debug.Print ""
　　　　　　Next
　　　　End With
　　End With
End Sub

２）再帰処理で考える【標準モジュール：Pat2r】

２－１）重複結果を Dictionary のキーで管理

総当たりする部分を再帰処理にします。
計算結果を Dictionary のキーとして利用し重複を排除します。

Dim dic As Object

Private Sub ReCallCurAdd(iNst As Long, vAry As Variant, cSrc As Currency)
　　Dim v As Variant
　　Dim c As Currency

　　For Each v In vAry
　　　　c = cSrc + v
　　　　If (iNst <= 1) Then
　　　　　　dic.Item(c) = Null
　　　　Else
　　　　　　Call ReCallCurAdd(iNst - 1, vAry, c)
　　　　End If
　　Next
End Sub

Public Sub Sample1()
　　Dim vAry As Variant
　　Dim vBase As Variant
　　Dim vTmp As Variant
　　Dim i As Long, jB As Long, jA As Long, k As Long

　　Const iCount As Long = 3

　　vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'　　vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

　　For i = 0 To UBound(vAry)
　　　　vAry(i) = CCur(vAry(i))
　　Next

　　Set dic = CreateObject("Scripting.Dictionary")
　　Call ReCallCurAdd(iCount, vAry, 0)
　　vBase = dic.keys
　　Set dic = Nothing

　　For i = 0 To UBound(vBase) - 1
　　　　For k = i + 1 To UBound(vBase)
　　　　　　If (vBase(k) < vBase(i)) Then
　　　　　　　　vTmp = vBase(i)
　　　　　　　　vBase(i) = vBase(k)
　　　　　　　　vBase(k) = vTmp
　　　　　　End If
　　　　Next
　　Next

　　For i = 0 To UBound(vBase)
　　　　Debug.Print vBase(i)
　　Next
End Sub

２－２）重複しない結果を都度整列生成

基本的には２－１）と同じですが、Dictionary 部分の使い方が変わってきます。
重複しない結果が得られたら･････
これ、Dictionary に設定する時に管理している個数に変化があったかで判別しています。
変化あったら重複しない値だった････なので、自分で都度昇順に格納していきます。

Dim dic As Object
Dim cAry As Variant ' Sample2 で使用

Private Sub CurAdd2(cSrc As Currency)
　　Dim i As Long
　　Dim j As Long

　　If (IsEmpty(cAry)) Then
　　　　ReDim cAry(0)
　　　　cAry(0) = cSrc
　　Else
　　　　For i = 0 To UBound(cAry)
　　　　　　If (cAry(i) > cSrc) Then
　　　　　　　　ReDim Preserve cAry(UBound(cAry) + 1)
　　　　　　　　For j = UBound(cAry) - 1 To i Step -1
　　　　　　　　　　cAry(j + 1) = cAry(j)
　　　　　　　　Next
　　　　　　　　cAry(i) = cSrc
　　　　　　　　Exit For
　　　　　　End If
　　　　Next
　　　　If (i > UBound(cAry)) Then
　　　　　　ReDim Preserve cAry(i)
　　　　　　cAry(i) = cSrc
　　　　End If
　　End If
End Sub

Private Sub ReCallCurAdd2(iNst As Long, vAry As Variant, cSrc As Currency)
　　Dim v As Variant
　　Dim c As Currency
　　Dim i As Long

　　For Each v In vAry
　　　　c = cSrc + v
　　　　If (iNst <= 1) Then
　　　　　　i = dic.Count
　　　　　　dic.Item(c) = Null
　　　　　　If (dic.Count <> i) Then Call CurAdd2(c)
　　　　Else
　　　　　　Call ReCallCurAdd2(iNst - 1, vAry, c)
　　　　End If
　　Next
End Sub

Public Sub Sample2()
　　Dim vAry As Variant
　　Dim i As Long

　　Const iCount As Long = 3

　　vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'　　vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

　　For i = 0 To UBound(vAry)
　　　　vAry(i) = CCur(vAry(i))
　　Next

　　cAry = Empty
　　Set dic = CreateObject("Scripting.Dictionary")
　　Call ReCallCurAdd2(iCount, vAry, 0)
　　Set dic = Nothing

　　For i = 0 To UBound(cAry)
　　　　Debug.Print cAry(i)
　　Next
End Sub

２－３）重複しない組み合わせを事前に求める

今回は足し算でそう時間がかかるものではありませんが、考え方として････
総当たりで計算するのではなく、計算が必要なケースを探します。
この時再帰処理を使用します。
元の配列数と同じ中身 0 の変数を用意し、どのケースがあるか調べます。
このケースの管理に Dictionary を使用します。
Dictionary に格納される内容としては、"0,3;1,0;2,0;3,0;4,0" のような文字列になります。
これは、
A(0)+B(0)+C(1)= や A(0)+B(1)+C(0)= や A(1)+B(0)+C(0)=
これら全て計算する必要はなく (0) を２回、(1) を１回のケースですね････
この場合、"0,2;1,1;2,0;3,0;4,0" とするルールを決めました。
";" 区切りで、その中を "," で区切って　(0) が配列参照の添え字に、(1) が回数に

（実際に必要な "0,2;1,1" だけの方が良かったのかも････）

必要なケースだけやったとしても、計算結果が重複しない保証はないので、
また　Dictionary　を使って重複排除

Dim dic As Object

Private Sub ReCallMake3(iNst As Long, vAry As Variant)
　　Dim i As Long, j As Long
　　Dim sS As String
　　Dim vWrkAry As Variant

　　For i = 0 To UBound(vAry)
　　　　vWrkAry = vAry
　　　　vWrkAry(i) = vWrkAry(i) + 1
　　　　If (iNst <= 1) Then
　　　　　　sS = ""
　　　　　　For j = 0 To UBound(vWrkAry)
　　　　　　　　sS = sS & ";" & j & "," & vWrkAry(j)
　　　　　　Next
　　　　　　dic.Item(Mid(sS, 2)) = Null
　　　　Else
　　　　　　Call ReCallMake3(iNst - 1, vWrkAry)
　　　　End If
　　Next
End Sub

Public Sub Sample3()
　　Dim vAry As Variant
　　Dim vWrkAry As Variant
　　Dim vBase As Variant
　　Dim vTmp As Variant
　　Dim i As Long, j As Long
　　Dim vKs As Variant, vK As Variant
　　Dim vAs As Variant, vA As Variant
　　Dim c As Currency, cW As Currency

　　Const iCount As Long = 3

　　vAry = Array(0, 1.1, 4.4, 3.3, 2.2)
'　　vAry = Array(0, 9.9, 1.1, 8.8, 2.2, 7.7, 3.3, 6.6, 4.4, 5.5)

　　vWrkAry = vAry
　　For i = 0 To UBound(vWrkAry)
　　　　vWrkAry(i) = 0
　　Next

　　Set dic = CreateObject("Scripting.Dictionary")
　　Call ReCallMake3(iCount, vWrkAry)

　　vKs = dic.keys
　　dic.RemoveAll

　　For Each vK In vKs
　　　　c = 0
　　　　For Each vAs In Split(vK, ";")
　　　　　　vA = Split(vAs, ",")
　　　　　　cW = vAry(CLng(vA(0)))
　　　　　　For i = 1 To CLng(vA(1))
　　　　　　　　c = c + cW
　　　　　　Next
　　　　Next
　　　　dic.Item(c) = Null
　　Next
　　vBase = dic.keys
　　Set dic = Nothing

　　For i = 0 To UBound(vBase) - 1
　　　　For j = i + 1 To UBound(vBase)
　　　　　　If (vBase(j) < vBase(i)) Then
　　　　　　　　vTmp = vBase(i)
　　　　　　　　vBase(i) = vBase(j)
　　　　　　　　vBase(j) = vTmp
　　　　　　End If
　　　　Next
　　Next

　　For i = 0 To UBound(vBase)
　　　　Debug.Print vBase(i)
　　Next
End Sub

５、６組ぐらいまでなら再帰も使えるかも･････
それ以上だと･････････

この処理では、１－２）が格段に速い、良いですね。
５０組でもソコソコの応答があるし･････

関連記事