スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

再帰処理にはまる(その4 乾杯!!) 


乾杯?
これは誤変換ですね、「完敗」が正しいものになります。

No989.合計探索問題、みなさんの頭脳に挑戦!!^^;
http://www.accessclub.jp/bbs7/0002/bbs989.html

これを見てから、いろいろと挑戦してみていました。
そこそこは良さそうなんだけど、そもそもの考え方を変えないと超えれないんですかね・・・・
ここで、問題を再度

テーブル「T1」があったとします。
IDF1
1381
2650
3809
4870
5765
6777
7838
8806
9133
10397
1162
12132
13415
1427
15993
16121
17348
18768
19394
20297

ここで、このデータのすべての組み合わせの中から、指定した合計の組み合わせを求めなさい。
例えば、合計が、1574 になる組み合わせは、
3, 5
2, 5, 12, 14
など

最近 moug の Excel VBA でも似たようなものがありましたね。

私が考えてみたのは7つ
・データごと配列に展開し直してやってみる(Module11 ~ Module14)
kEnt126_img11 kEnt126_img12 kEnt126_img13 kEnt126_img14
・データの展開先にインメモリレコードセットを使ってみる(Module21 ~ Module22)
kEnt126_img21 kEnt126_img22
・個数を制限して、その個数内で求めてみる(Module31)
kEnt126_img31
どの方法でも近づけなかったですね・・・・・
そもそもの考え方は1つですから・・・・・・・・・・
これを確認する為のフォームを作っています。
kEnt126_11a  kEnt126_11b  kEnt126_31b
ここでテーブル「T2」としてレコード数を 20 件から 30 件に増やし、重複する「F1」を1つ
テーブル「T2」で確認する時には、検索値をジワジワと増やしていっていてください。
いきなり増やすと「応答なし」になったりします。
用意したフォームは「F11」「F12」「F13」「F14」「F21」「F22」「F31」の7つ&「F11B」1つ
フォーム名「F」以降は、処理を記述した Module の後ろと同じになっています。
(「11B」は「11」のベタ記述版(再帰部分が遅くなっているのか・・・・・さほど変わりなし(記述方法?)))

また、確認フォームでリスト内をダブルクリックした時には確認用として
kEnt126_Show  kEnt126_Show2003
のフォームが起動されるようになってます。
(個数分を、スクロールしなくてもピッタリと表示できるように工夫)
2007 以降の時には「帳票フォーム」形式(左の図)、その前では「リストボックス」形式(右の図)にて・・・・
( InStr(CurrentProject.Connection.Provider, "ACE") = 0 で起動フォーム切り替え)
( F_SHOW(帳票フォーム) か F_SHOW2003(リスト表示) か)
起動しているバージョンをどう判別するか・・・・これ、わからなかったので・・・・・

処理の速い順となると「F31」≧「F11B」≒「F11」>「F14」>「F13」>「F12」>「F22」>「F21」かな

なお、投稿内にある
hatena さん、YU-TANG さん(クラス および TYPE )の内容を確認できるようにしています。
(コピーして私なりのインデントを付加/テーブル名を変更した形で標準モジュールにて)
(インデントがないと理解しにくいので・・・・って、理解できてませんが・・・・・)
※ このような場合、どのような許可を取れば良いのでしょうか???

同じ環境で起動できるので、違いをみるには良いのかと・・・・・・・・・
 

確認用テーブル


確認用テーブルは、設問にあった内容のテーブル「T1」
レコード数を 30 件に増やし、重複の値が1つあるテーブル「T2」
(標準モジュール「T2Make」でいろいろ作成できます)
後述の標準モジュール「Module11」の処理経過を計測格納するテーブル「T3」
(標準モジュール「T3Make」で内容は作成されます)
ただし、1万件のレコードになるのでサンプル上は空(サイズがでかくなるので)
でも、実行すれば作成できるので・・・・ってことに。
※ 私の環境で「T3」の内容(1万件)作成するまで、 25 分弱
(Intel Core(TM)2 Duo CPU T7250 @2.00 GHz メモリ 2.5GB Vista Ultimate SP2 Office2007Pro SP3)

なお、出来上がったテーブル「T3」を Excel 出力する標準モジュール「ToExcel」もあり・・・・

確認用画面


確認用画面はほとんど共通です。
kEnt126_11a  kEnt126_11b
テーブルを選択するオプショングループ「op0」
そのテーブルのレコード数を表示するテキストボックス  =DCount("*","T" & [op0])
そのテーブルの「F1」の総計を表示するテキストボックス  =DSum("F1","T" & [op0])
表示を選ぶオプショングループ「op1」
検索値を入力するテキストボックス「txt3」
パターン数を表示するテキストボックス  =[lst1].[ListCount]
検索したパターンを表示するリストボックス「lst1」

リストボックス「lst1」は、「値集合タイプ」を「値リスト」に設定
検索した結果を VBA で展開して、リストボックスへ表示するようにします。

記述したのは以下で、黄色部分が処理によって異なるだけです。
Private Sub Form_Load()
  Call btn1_Click
  Me.txt3 = 1574
End Sub

Private Sub op0_Click()
  Me.Recalc
  Me.txt3.SetFocus
End Sub

Private Sub op1_Click()
  Me.txt3.SetFocus
End Sub

Private Sub btn1_Click()
  Me.lst1 = Null
  Me.lst1.RowSource = ""
  Me.lst1.Controls(0).Caption = ""
  Me.txt3.SetFocus
End Sub

Private Sub txt3_KeyDown(KeyCode As Integer, Shift As Integer)
  Dim st As Single
  Dim v As Variant

  Select Case KeyCode
    Case vbKeyReturn
      KeyCode = 0
      If (Len(Me.txt3.Text) = 0) Then Exit Sub
      If (Not IsNumeric(Me.txt3.Text)) Then Exit Sub
      Me.btn1.Enabled = False
      Me.Repaint
      st = Timer
      Select Case Me.op1
        Case 1: v = Module11.SumSearch("T" & Me.op0, "ID", CLng(Me.txt3.Text))
        Case 2: v = Module11.SumSearch("T" & Me.op0, "F1", CLng(Me.txt3.Text))
      End Select
      st = Timer - st
      Me.lst1.Controls(0).Caption = "処理時間 " & Format(st, "0.000 秒")
      If (IsEmpty(v)) Then
        Me.lst1.RowSource = ""
      Else
        On Error Resume Next
        Me.lst1.RowSource = """" & Join(v, """;""") & """"
        If (Err <> 0) Then
          Me.lst1.RowSource = "RowSource 設定でエラー 件数(" & UBound(v) + 1 & ")"
        End If
      End If
      Me.lst1 = Null
      Me.Recalc
      Me.btn1.Enabled = True
      Me.txt3.SelStart = 0
      Me.txt3.SelLength = Len(Me.txt3.Text)
  End Select
End Sub

Private Sub lst1_DblClick(Cancel As Integer)
  On Error Resume Next
  If (Not IsNull(Me.lst1.Column(0))) Then DoCmd.OpenForm "F_SHOW"
End Sub

 
値検索の実行は、検索値入力部分で「Enter」キーを押下することで行われます。
なので、極力検索値入力テキストボックスにフォーカスを設定するようにしています。
また、「タブストップ」は検索値入力テキストボックス「txt3」のみ「はい」としておきます。

標準モジュールに記述した関数を呼び出し、
その結果をリストボックスへ「値リスト」として設定していきますが、
設定できる文字数制限がある様で、特に 2000 で設定エラーが多く発生します。
その時には、設定のエラーであること+件数のみを表示するようにします。

リストボックス「lst1」をダブルクリックされた時、抽出したものが正しいものなのか・・・・
これを表示するフォームを起動するようにします。
(リストボックスで選ばれているものがあったら・・・・・)
(私はこの判別方法を良くやってましたけど・・・・・ ListIndex の方が良いんでしょうか・・・・)

フォームを起動しますが、起動されたフォームの Form_Open で Cancel = True を返すことがあるので、
エラーの発生を無視するように On Error Resume Next を記述しておきます。

※ ここで新しい発見あり
リストボックスを「値リスト」で、かつ「ダブルクリックでフォーム起動」・・・・・
これ、あまりやったことがなかったのですが、
起動するフォームを「ポップアップ」を「はい」、「作業ウィンドウ固定」を「はい」に設定していても
起動後、リストボックス付近をクリックすると、起動したフォームが裏に隠れる現象が発生・・・・

ダブルクリックの Cancel = True しても変化なし・・・・

いろいろやってみると・・・・
リストボックスの「値リストの編集許可」が「はい」となっていると起きるようです。
「値リストの編集許可」を「いいえ」とすると裏に隠れる様な事はなくなりました。
(2007 にて・・・・・ 2007 で作っていたので他のバージョンでは未確認)
(この対処が良かったのかは・・・・・・・)

起動されるフォーム「F_SHOW」

kEnt126_Show  kEnt126_ShowD
このフォームでは、
自分が生きて帳票形式で表示するか、
自分を終了してリストボックス表示の「F_SHOW2003」を起動するか処理します。
表示したレコード自体はいじらせたくないので、各テキストボックスの「編集ロック」は「はい」に。
また、追加/更新/削除が出来ない様にしておきます。

Form_Open ではお決まりの、直に起動された時には表示しない様にしておいて・・・
起動元のリストボックス表示が正しいか・・・・
CurrentProject.Connection.Provider 文字列内に "ACE" があるか・・・・

このフォーム「F_SHOW」(帳票形式)では、
レコードセットに ADODBインメモリレコードセットを使うので、過去記事で 2000 で使えなかったこともあり
起動バージョンで切り替えるように・・・・・
2003 をどうしようか考えたけど表示に大差はないよね・・・・・ってことで、上記判別にて・・・・

表示に関しては、表示する件数を取得したら、
「詳細」の高さx件数+α を加味したフォームの高さを再設定します。

また、数字が表示されている部分をダブルクリックされたら、フォームを閉じるように・・・
Dim rs As ADODB.Recordset
Dim sS As String

Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Screen.ActiveControl.Name = "") Then
    Cancel = True
  Else
    sS = Screen.ActiveControl
    If (sS Like "*[!0-9( )]*") Then Cancel = True
  End If

  If (Not Cancel) Then
    If (InStr(CurrentProject.Connection.Provider, "ACE") = 0) Then
      DoCmd.OpenForm "F_SHOW2003"
      Cancel = True
    End If
  End If
End Sub

Private Function ClsFrm()
  DoCmd.Close acForm, Me.Name, acSaveNo
End Function

Private Sub Form_Load()
  Dim v As Variant
  Dim iTotal As Long
  Const F1 As String = "F1"
  Const F2 As String = "F2"
  Const F3 As String = "F3"

  Set rs = New ADODB.Recordset
  With rs
    With .Fields
      .Append F1, adInteger
      .Append F2, adInteger
      .Append F3, adInteger
    End With
    .LockType = adLockOptimistic
    .Open
  End With

  iTotal = 0
  sS = Replace(sS, ")", "")
  For Each v In Split(sS, " ")
    v = Split(v, "(")
    rs.AddNew
    rs(0) = iTotal
    rs(1) = CLng(v(UBound(v)))
    iTotal = iTotal + rs(1)
    rs(2) = iTotal
    rs.Update
  Next

  Me.InsideHeight = Me.Section(acHeader).Height _
          + Me.Section(acDetail).Height * rs.RecordCount _
          + Me.Section(acFooter).Height _
          + rs.RecordCount * 3
  Set Me.Recordset = rs
  Me.txt1.ControlSource = F1
  Me.txt2.ControlSource = F2
  Me.txt3.ControlSource = F3
  Me.txt11 = rs.RecordCount
  Me.txt12 = iTotal
  Me.txt1.OnDblClick = "=ClsFrm()"
  Me.txt2.OnDblClick = "=ClsFrm()"
  Me.txt3.OnDblClick = "=ClsFrm()"
  Me.txt11.OnDblClick = "=ClsFrm()"
  Me.txt12.OnDblClick = "=ClsFrm()"
End Sub

Private Sub Form_Close()
  If (Not rs Is Nothing) Then rs.Close
  Set rs = Nothing
End Sub

 
起動されるフォーム「F_SHOW2003」

kEnt126_Show2003
フォーム「F_SHOW」を「F_SHOW2003」でコピーし、「既定のビュー」は単票フォームにしておきます。
「詳細」に配置してあったものすべてを削除し、リストボックス「lst1」を配置し直します。
また、「値集合タイプ」を「値リスト」にし、固定幅フォントを指定しておきます。

リストボックス形式で表示する時に起動されます。
ここでも、お決まりのように、直に起動されない様にしておいて・・・・
数値を右詰で作成す時には、 RSet を使用し調整します。

表示する件数によりリストの高さを変更していきますが、
初めに「詳細」部分の高さをリストの高さ以上に設定してから行います。
「詳細」の高さをリストの高さに関係なく30cm とか大きく設定しても、
InsideHeight 設定時、指定した高さ - ヘッダの高さ - フッタの高さ で、
「詳細」の高さが決まるような雰囲気です。
リストボックスの高さ変更時、「詳細」を超えたらエラーになった様な・・・・気がしますが・・・未確認

また、数字が表示されている部分のダブルクリックで、フォームを閉じるように・・・・
Private Sub Form_Open(Cancel As Integer)
  On Error Resume Next
  If (Screen.ActiveControl.Name = "") Then
    Cancel = True
  End If
End Sub

Private Function ClsFrm()
  DoCmd.Close acForm, Me.Name, acSaveNo
End Function

Private Sub Form_Load()
  Dim sS As String
  Dim vLst As Variant
  Dim v As Variant
  Dim s As String
  Dim sTmp As String
  Dim iCnt
  Dim iTotal As Long

  sS = Screen.ActiveControl
  
  iCnt = 0: iTotal = 0: s = Space(7)
  sS = Replace(sS, ")", "")
  For Each v In Split(sS, " ")
    v = Split(v, "(")
    RSet s = iTotal
    sTmp = s & " + "
    RSet s = CLng(v(UBound(v)))
    sTmp = sTmp & s & " = "
    iTotal = iTotal + CLng(v(UBound(v)))
    RSet s = iTotal
    sTmp = sTmp & s
    iCnt = iCnt + 1
    
    If (IsEmpty(vLst)) Then
      ReDim vLst(0)
    Else
      ReDim Preserve vLst(UBound(vLst) + 1)
    End If
    vLst(UBound(vLst)) = sTmp
  Next

  Me.Section(acDetail).Height = Me.lst1.Top + (iCnt * 242) + 100

  Me.lst1.Height = iCnt * 242 + 20
  Me.InsideHeight = Me.Section(acHeader).Height _
          + Me.lst1.Top + Me.lst1.Height _
          + Me.Section(acFooter).Height _
          + 20

  Me.lst1.RowSource = """" & Join(vLst, """;""") & """"
  Me.txt11 = iCnt
  Me.txt12 = iTotal
  Me.lst1.OnDblClick = "=ClsFrm()"
  Me.txt11.OnDblClick = "=ClsFrm()"
  Me.txt12.OnDblClick = "=ClsFrm()"
End Sub

 

モジュール


ここでは「Module11」「Module21」について記述してみます。
他の記述も似通っているので、興味あればサンプルファイル内を見てください。

Module11
 
kEnt126_img11
上記、処理イメージに全部書いた様な気もします。
Private Type AryData
  F1 As Long
  ID As Long
End Type

Private Type PosData
  fx_pos As Long
  mv_Apos As Long
  mv_Bpos As Long
End Type

Private Const FLD_ID As String = "ID"
Private Const FLD_F1 As String = "F1"

Dim dic As Object

Private Function RecRead(sTable As String) As AryData()
  Dim rs As New ADODB.Recordset
  Dim tArySrc() As AryData
  Dim i As Long

  ReDim tArySrc(0)
  i = -1
  rs.Source = "SELECT " & FLD_ID & "," & FLD_F1 & " FROM " & sTable _
        & " ORDER BY " & FLD_F1 & "," & FLD_ID & ";"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    i = i + 1
    If (i <> 0) Then ReDim Preserve tArySrc(i)
    tArySrc(i).F1 = rs(FLD_F1)
    tArySrc(i).ID = rs(FLD_ID)
    rs.MoveNext
  Wend
  rs.Close
  RecRead = tArySrc
End Function

Private Function VarSort(sSel As String, tPosSrc As PosData, tAryDest() As AryData) As Variant
  Dim vr As Variant
  Dim i As Long
  Dim v As Variant

  ReDim vr(tPosSrc.fx_pos)
  Select Case sSel
    Case FLD_ID
        For i = 0 To tPosSrc.fx_pos
          vr(i) = tAryDest(i).ID
        Next
    Case FLD_F1
        For i = 0 To tPosSrc.fx_pos
          vr(i) = tAryDest(i).F1
        Next
    Case Else
        Exit Function
  End Select

  Do
    v = Empty
    For i = 0 To UBound(vr) - 1
      If (vr(i) > vr(i + 1)) Then
        v = vr(i)
        vr(i) = vr(i + 1)
        vr(i + 1) = v
      End If
    Next
  Loop While (Not IsEmpty(v))
  VarSort = vr
End Function

Private Function NextAryInfo(iNum As Long, tPosSrc As PosData, tArySrc() As AryData) As Long
  Dim i As Long

  NextAryInfo = 0
  With tPosSrc
    .mv_Apos = .mv_Apos + 1
    If (.mv_Apos > .mv_Bpos) Then Exit Function
    If (tArySrc(.mv_Apos).F1 > iNum) Then Exit Function
    While (tArySrc(.mv_Bpos).F1 > iNum)
      .mv_Bpos = .mv_Bpos - 1
    Wend
  
    i = .mv_Bpos - .mv_Apos + 1
    Select Case i
      Case 1: If (tArySrc(.mv_Apos).F1 <> iNum) Then Exit Function
      Case 2
        If (tArySrc(.mv_Apos).F1 <> iNum) Then
          If ((tArySrc(.mv_Apos).F1 + tArySrc(.mv_Bpos).F1) > iNum) Then
            If (tArySrc(.mv_Bpos).F1 <> iNum) Then Exit Function
            .mv_Apos = .mv_Bpos
            i = 1
          End If
        End If
    End Select
    NextAryInfo = i
  End With
End Function

Private Sub ReCallSum(iNum As Long, tPosSrc As PosData, tArySrc() As AryData, tAryDest() As AryData)
  Dim tPosWsrc As PosData, tPosToSrc As PosData
  Dim iNumNew As Long
  Dim i As Long, j As Long
  Dim vAry As Variant
  Dim v As Variant
  Dim sS As String

  With tPosSrc
    j = 0
    For i = .mv_Apos To .mv_Bpos
      j = j + tArySrc(i).F1
    Next
  End With
  If ((j = 0) Or (iNum > j)) Then Exit Sub

  tPosWsrc = tPosSrc
  With tPosWsrc
    .fx_pos = .fx_pos + 1
    Do While (.mv_Apos <= .mv_Bpos)
      iNumNew = iNum - tArySrc(.mv_Apos).F1
      If (iNumNew < 0) Then Exit Do
      tAryDest(.fx_pos) = tArySrc(.mv_Apos)
      If (iNumNew = 0) Then
        For Each vAry In Array(FLD_F1, FLD_ID)
          sS = ""
          For Each v In VarSort(CStr(vAry), tPosWsrc, tAryDest)
            sS = sS & ";" & Format(v, "0000")
          Next
          dic.Item(vAry & sS) = Null
        Next
      Else
        tPosToSrc = tPosWsrc
        If (NextAryInfo(iNumNew, tPosToSrc, tArySrc) <> 0) Then
          Call ReCallSum(iNumNew, tPosToSrc, tArySrc, tAryDest)
        End If
      End If
      .mv_Apos = .mv_Apos + 1
    Loop
  End With
End Sub

Private Function SearchF1(sSel As String, iNum As Long, tArySrc() As AryData) As String
  Dim i As Integer

  SearchF1 = ""
  If (sSel = FLD_F1) Then Exit Function

  For i = 0 To UBound(tArySrc)
    If (tArySrc(i).ID = iNum) Then
      SearchF1 = "(" & tArySrc(i).F1 & ")"
      Exit For
    End If
  Next
End Function

Public Function SumSearch(sTable As String, sSel As String, iNum As Long) As Variant
  Dim tArySrc() As AryData, tAryDest() As AryData
  Dim tPosSrc As PosData
  Dim vAry As Variant, vAryR As Variant
  Dim v As Variant
  Dim i As Long, j As Long
  Dim sS As String

  tArySrc = RecRead(sTable)
  If (tArySrc(0).ID = 0) Then Exit Function
  tAryDest = tArySrc
  With tPosSrc
    .fx_pos = -1
    .mv_Apos = 0
    .mv_Bpos = UBound(tArySrc)
  End With
  Set dic = CreateObject("Scripting.Dictionary")
  Call ReCallSum(iNum, tPosSrc, tArySrc, tAryDest)
  If (dic.Count > 0) Then
    vAry = dic.Keys
    Do
      v = Empty
      For i = 0 To UBound(vAry) - 1
        If (vAry(i) > vAry(i + 1)) Then
          v = vAry(i)
          vAry(i) = vAry(i + 1)
          vAry(i + 1) = v
        End If
      Next
    Loop While (Not IsEmpty(v))

    For i = 0 To UBound(vAry)
      sS = ""
      v = Split(vAry(i), ";")
      If (v(0) = sSel) Then
        For j = 1 To UBound(v)
          sS = sS & " " & CLng(v(j)) & SearchF1(sSel, CLng(v(j)), tArySrc)
        Next
        If (IsEmpty(vAryR)) Then
          ReDim vAryR(0)
        Else
          ReDim Preserve vAryR(UBound(vAryR) + 1)
        End If
        vAryR(UBound(vAryR)) = Mid(sS, 2)
      End If
    Next
  End If
  Set dic = Nothing
  SumSearch = vAryR
End Function

Public Sub Sample()
  Dim sS As String
  Dim st As Single
  Dim v As Variant
  Dim i As Long

  Do While (1)
    sS = InputBox("合計値を入力してください", "パターン検索", "1574")
    If (Len(sS) = 0) Then Exit Do
    If (Not IsNumeric(sS)) Then Exit Do
    st = Timer
    v = SumSearch("T1", FLD_F1, CLng(sS))
    If (IsEmpty(v)) Then
      Debug.Print ">>> " & sS & " の件数(0)"
    Else
      For i = 0 To UBound(v)
        Debug.Print sS & " = " & v(i)
      Next
      Debug.Print ">>> " & sS & " の件数(" & UBound(v) + 1 & ")"
    End If
    Debug.Print "終了------------処理時間:" & Format(Timer - st, "0.000\秒")
  Loop
End Sub

 
検索値が見つかったら、";" 区切りで、何のデータか先頭に "ID" or "F1" を付加して・・・・
「F1」の値をソートしたものと、「ID」をソートしたものを Dictionary に格納することにしました。
表示した時、ソートされているのが見やすいかな・・・・・ここは妥協できないかなぁ
格納する時に各値を4桁の文字に揃えて・・・・
(なので5桁以上の値の場合、おかしくなるかと思います)

これは、格納先に Dictionary を選んだので、重複があったら削ってくれる・・・・
(F1 の値に重複があった場合、値表示時には重複を削除したもので・・・・)
(ID 表示の場合は重複するものがないので、そのまま表示されると思います)

例)
IDF1
120
230
380
420
540

というデータがあった場合に 100 を求めたいとすると
・F1(値)での表示では
 20 80
 の1件になると思いますが
・ID での表示では
 1(20) 3(80)3(80) 4(20)
 の2件になります。

こういう事をやりたかった・・・・っていうのもあって Dictionary を選んだ・・・・・とも言えるかなっと

再帰呼出しの心臓部分、以下がどのような感じで動いているのか調べてみました。
(標準モジュール「T3Make」で、調査結果をテーブル「T3」に作成します)
Private Sub ReCallSum(iNum As Long, tPosSrc As PosData, tArySrc() As AryData, tAryDest() As AryData)
  Dim tPosWsrc As PosData, tPosToSrc As PosData
  Dim iNumNew As Long
  Dim i As Long, j As Long
  Dim vAry As Variant
  Dim v As Variant
  Dim sS As String

  ★★ ここで「関数呼」を計測
  With tPosSrc
    j = 0
    For i = .mv_Apos To .mv_Bpos
      j = j + tArySrc(i).F1
    Next
  End With
  If ((j = 0) Or (iNum > j)) Then Exit Sub

  tPosWsrc = tPosSrc
  With tPosWsrc
    .fx_pos = .fx_pos + 1
    Do While (.mv_Apos <= .mv_Bpos)
      ★★ ここで「処理数」を計測
      iNumNew = iNum - tArySrc(.mv_Apos).F1
      If (iNumNew < 0) Then Exit Do
      tAryDest(.fx_pos) = tArySrc(.mv_Apos)
      If (iNumNew = 0) Then
        ★★ ここで「組合せ数」を計測
        For Each vAry In Array(FLD_F1, FLD_ID)
          sS = ""
          For Each v In VarSort(CStr(vAry), tPosWsrc, tAryDest)
            sS = sS & ";" & Format(v, "0000")
          Next
          dic.Item(vAry & sS) = Null
        Next
      Else
        tPosToSrc = tPosWsrc
        If (NextAryInfo(iNumNew, tPosToSrc, tArySrc) <> 0) Then
          Call ReCallSum(iNumNew, tPosToSrc, tArySrc, tAryDest)
        End If
      End If
      .mv_Apos = .mv_Apos + 1
    Loop
  End With
End Sub

 
計測した結果は以下の通りとなりました。

最小値、基準値、最大値での結果は
検索値関数呼処理数組合せ数
27 
993 84 547 
1574 383 3186 
 それぞれでの最大値となるのは
検索値関数呼処理数組合せ数
4897 90632 348453 360 
5086 101758 374971 360 
5892 142237 428015 286 
6410 152512 399892 210 

検索値 500 ごとの結果は以下になりました。
検索値関数呼処理数組合せ数
500 53 
1000 86 559 
1500 321 2626 12 
2000 1136 9682 19 
2500 3858 27664 55 
3000 10391 63150 110 
3500 22572 120002 175 
4000 41786 197296 248 
4500 67375 283983 288 
5000 96661 363297 321 
 
検索値関数呼処理数組合せ数
5500 124922 415693 306 
6000 145684 425487 231 
6500 152164 390086 163 
7000 141867 320059 111 
7500 115895 230606 54 
8000 80722 142787 19 
8500 46394 74042 
9000 19168 28014 
9500 4464 5956 
10000 

ただ、私が作成した Module11 でのものなので参考になるのかどうか・・・・
特に「組合せ数」は検証してください。

追記 4/21
--
Private Function NextAryInfo(iNum As Long, tPosSrc As PosData, tArySrc() As AryData) As Long
  Dim i As Long

  NextAryInfo = 0
  With tPosSrc
    .mv_Apos = .mv_Apos + 1
    If (.mv_Apos > .mv_Bpos) Then Exit Function
    If (tArySrc(.mv_Apos).F1 > iNum) Then Exit Function
    While (tArySrc(.mv_Bpos).F1 > iNum)
      .mv_Bpos = .mv_Bpos - 1
    Wend
  
    i = .mv_Bpos - .mv_Apos + 1
    Select Case i
      Case 1: If (tArySrc(.mv_Apos).F1 <> iNum) Then Exit Function
      Case 2
        If (tArySrc(.mv_Apos).F1 <> iNum) Then
'          If ((tArySrc(.mv_Apos).F1 + tArySrc(.mv_Bpos).F1) > iNum) Then
          If ((tArySrc(.mv_Apos).F1 + tArySrc(.mv_Bpos).F1) <> iNum) Then
            If (tArySrc(.mv_Bpos).F1 <> iNum) Then Exit Function
            .mv_Apos = .mv_Bpos
            i = 1
          End If
        End If
    End Select
    NextAryInfo = i
  End With
End Function
極力、再帰呼出し回数を減らすように、上記 Select 文で判別しやすい範囲でチェックしていましたが、
黄色部分の判別が足りてませんでした。
上記を変更したことで「処理数」「組合せ数」に変化はありませんでしたが「関数呼」は、
最大、「検索値」6732 の 149934 回を 111738 回へと 38196 減らすことが出来ました。
(時間的目安は 0.336 から 0.320 に改善・・・・)

「関数呼」改善差 TOP 10
検索値変更前変更後
6732 149934 111738 38196 
6756 149412 111220 38192 
6733 149935 111745 38190 
6735 149851 111661 38190 
6734 149872 111683 38189 
6728 150055 111867 38188 
6729 150012 111824 38188 
6730 149993 111805 38188 
6731 149969 111781 38188 
6727 150044 111857 38187 

なお、求める動作自体には影響ないので、サンプルファイルは未修正
--

ちなみに使用個数を限定した場合「Module31」での変更箇所は少なく、以下の黄色部分
(iNst が使用個数を指定するもの)
Private Sub ReCallSum(iNst As Long, iNum As Long _
          , tPosSrc As PosData, tArySrc() As AryData, tAryDest() As AryData)
  Dim tPosWsrc As PosData, tPosToSrc As PosData
  Dim iNumNew As Long
  Dim i As Long, j As Long
  Dim vAry As Variant
  Dim v As Variant
  Dim sS As String

  If (iNst < 1) Then Exit Sub
  With tPosSrc
    j = 0
    For i = .mv_Apos To .mv_Bpos
      j = j + tArySrc(i).F1
    Next
  End With
  If ((j = 0) Or (iNum > j)) Then Exit Sub

  tPosWsrc = tPosSrc
  With tPosWsrc
    .fx_pos = .fx_pos + 1
    Do While (.mv_Apos <= .mv_Bpos)
      iNumNew = iNum - tArySrc(.mv_Apos).F1
      If (iNumNew < 0) Then Exit Do
      tAryDest(.fx_pos) = tArySrc(.mv_Apos)
      If (iNumNew = 0) Then
        For Each vAry In Array(FLD_F1, FLD_ID)
          sS = ""
          For Each v In VarSort(CStr(vAry), tPosWsrc, tAryDest)
            sS = sS & ";" & Format(v, "0000")
          Next
          dic.Item(vAry & sS) = Null
        Next
      ElseIf (iNst > 1) Then
        tPosToSrc = tPosWsrc
        If (NextAryInfo(iNumNew, tPosToSrc, tArySrc) <> 0) Then
          Call ReCallSum(iNst - 1, iNumNew, tPosToSrc, tArySrc, tAryDest)
        End If
      End If
      .mv_Apos = .mv_Apos + 1
    Loop
  End With
End Sub

 
もちろんパラメータ iNst が増えた分、呼び出し側にも変更はありますが・・・・

Module21
 
kEnt126_img21

Private Const FLD_ID As String = "ID"
Private Const FLD_F1 As String = "F1"
Private Const FLD_F1ID As String = "F1ID"
Private Const FLD_USE As String = "use"
Private Const POS_ID As Long = 0
Private Const POS_F1 As Long = 1
Private Const POS_F1ID As Long = 2
Private Const POS_USE As Long = 3

Dim dic As Object

Private Sub RecRead(sTable As String, rs As ADODB.Recordset)
  Dim rsIn As New ADODB.Recordset
  Dim i As Long

  rsIn.Source = "SELECT " & FLD_ID & "," & FLD_F1 & " FROM " & sTable _
        & " ORDER BY " & FLD_F1 & "," & FLD_ID & ";"
  rsIn.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  If (Not rsIn.EOF) Then
    Set rs = New ADODB.Recordset
    With rs
      With .Fields
        .Append FLD_ID, adInteger
        .Append FLD_F1, adInteger
        .Append FLD_F1ID, adInteger
        .Append FLD_USE, adInteger
      End With
      .LockType = adLockOptimistic
      .Open
    End With

    i = 1
    While (Not rsIn.EOF)
      rs.AddNew
      rs(POS_ID) = rsIn(POS_ID)
      rs(POS_F1) = rsIn(POS_F1)
      rs(POS_F1ID) = i
      rs(POS_USE) = 0
      rs.Update
      i = i + 1
      rsIn.MoveNext
    Wend
    rs.MoveFirst
  End If
  rsIn.Close
End Sub

Private Sub ReCallSum(iNum As Long, rs As ADODB.Recordset)
  Dim rsc As ADODB.Recordset
  Dim iNumNew As Long
  Dim i As Long
  Dim sS As String

  i = 0
  While (Not rs.EOF)
    i = i + rs(POS_F1)
    rs.MoveNext
  Wend
  If ((i = 0) Or (iNum > i)) Then Exit Sub
  rs.MoveFirst

  Set rsc = rs.Clone
  Do While (Not rs.EOF)
    iNumNew = iNum - rs(POS_F1)
    If (iNumNew < 0) Then Exit Do
    rs(POS_USE) = 1
    rs.Update
    If (iNumNew = 0) Then
      rsc.Filter = FLD_USE & " = 1"
      sS = ""
      rsc.Sort = FLD_F1
      While (Not rsc.EOF)
        sS = sS & ";" & Format(rsc(POS_F1), "0000")
        rsc.MoveNext
      Wend
      dic.Item(FLD_F1 & sS) = Null
      sS = ""
      rsc.Sort = FLD_ID
      While (Not rsc.EOF)
        sS = sS & ";" & Format(rsc(POS_ID), "0000")
        rsc.MoveNext
      Wend
      dic.Item(FLD_ID & sS) = Null
    Else
      rsc.Filter = "(" & FLD_F1ID & " > " & rs(POS_F1ID) & ")" _
            & " AND (" & FLD_F1 & " <= " & iNumNew & ")"
      If (rsc.RecordCount > 0) Then Call ReCallSum(iNumNew, rsc)
    End If
    rs(POS_USE) = 0
    rs.Update
    rs.MoveNext
  Loop
  rsc.Close
  Set rsc = Nothing
End Sub

Private Function SearchF1(sSel As String, iNum As Long, rs As ADODB.Recordset) As String
  SearchF1 = ""
  If (sSel = FLD_F1) Then Exit Function

  rs.MoveFirst
  rs.Find FLD_ID & " = " & iNum
  SearchF1 = "(" & rs(POS_F1) & ")"
End Function

Public Function SumSearch(sTable As String, sSel As String, iNum As Long) As Variant
  Dim rs As ADODB.Recordset
  Dim vAry As Variant, vAryR As Variant
  Dim v As Variant
  Dim i As Long, j As Long
  Dim sS As String

  Call RecRead(sTable, rs)
  If (rs Is Nothing) Then Exit Function
  Set dic = CreateObject("Scripting.Dictionary")
  Call ReCallSum(iNum, rs)
  If (dic.Count > 0) Then
    vAry = dic.Keys
    Do
      v = Empty
      For i = 0 To UBound(vAry) - 1
        If (vAry(i) > vAry(i + 1)) Then
          v = vAry(i)
          vAry(i) = vAry(i + 1)
          vAry(i + 1) = v
        End If
      Next
    Loop While (Not IsEmpty(v))

    For i = 0 To UBound(vAry)
      sS = ""
      v = Split(vAry(i), ";")
      If (v(0) = sSel) Then
        For j = 1 To UBound(v)
          sS = sS & " " & CLng(v(j)) & SearchF1(sSel, CLng(v(j)), rs)
        Next
        If (IsEmpty(vAryR)) Then
          ReDim vAryR(0)
        Else
          ReDim Preserve vAryR(UBound(vAryR) + 1)
        End If
        vAryR(UBound(vAryR)) = Mid(sS, 2)
      End If
    Next
  End If
  rs.Close
  Set rs = Nothing
  Set dic = Nothing
  SumSearch = vAryR
End Function

Public Sub Sample()
  Dim sS As String
  Dim st As Single
  Dim v As Variant
  Dim i As Long

  Do While (1)
    sS = InputBox("合計値を入力してください", "パターン検索", "1574")
    If (Len(sS) = 0) Then Exit Do
    If (Not IsNumeric(sS)) Then Exit Do
    st = Timer
    v = SumSearch("T1", FLD_F1, CLng(sS))
    If (IsEmpty(v)) Then
      Debug.Print ">>> " & sS & " の件数(0)"
    Else
      For i = 0 To UBound(v)
        Debug.Print sS & " = " & v(i)
      Next
      Debug.Print ">>> " & sS & " の件数(" & UBound(v) + 1 & ")"
    End If
    Debug.Print "終了------------処理時間:" & Format(Timer - st, "0.000\秒")
  Loop
End Sub

 

同じ土俵での確認


標準モジュール「__Sample確認」に記述しています。
各記述は、「_」で始まる名称で格納しています。
結果はイミディエイトウィンドウに表示されます。

Public Sub Show_kiku() ' ★★★★★ 実行場所 ★★★★★
  Call [_kiku].SumSearch(1574)
'  Call [_kiku].SumSearch(3000)
'  Call [_kiku].SumSearch(5000)
'  Call [_kiku].SumSearch(7000)
End Sub


Public Sub Show_hatena() ' ★★★★★ 実行場所 ★★★★★
  Call SearchSum(1574)
'  Call SearchSum(3000)
'  Call SearchSum(5000)
'  Call SearchSum(7000)
End Sub


Public Sub Show_Yu_tang_cls() ' ★★★★★ 実行場所 ★★★★★
  Call PackEntry(1574)
'  Call PackEntry(3000)
'  Call PackEntry(5000)
'  Call PackEntry(7000)
End Sub

Public Sub Show_Yu_tang_type() ' ★★★★★ 実行場所 ★★★★★
  Call SearchMain(1574)
'  Call SearchMain(3000)
'  Call SearchMain(5000)
'  Call SearchMain(7000)
End Sub

 
同じ土俵にのるために記述したのが「_kiku」(Module11 を元に修正)
Private Type AryData
  F1 As Long
  ID As Long
End Type

Private Type PosData
  fx_pos As Long
  mv_Apos As Long
  mv_Bpos As Long
End Type

Private Const FLD_ID As String = "ID"
Private Const FLD_F1 As String = "F1"

Dim sMsg As String
Dim iCnt As Long

Private Function RecRead(sTable As String) As AryData()
  Dim rs As New ADODB.Recordset
  Dim tArySrc() As AryData
  Dim i As Long

  ReDim tArySrc(0)
  i = -1
  rs.Source = "SELECT " & FLD_ID & "," & FLD_F1 & " FROM " & sTable _
        & " ORDER BY " & FLD_F1 & "," & FLD_ID & ";"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  While (Not rs.EOF)
    i = i + 1
    If (i <> 0) Then ReDim Preserve tArySrc(i)
    tArySrc(i).F1 = rs(FLD_F1)
    tArySrc(i).ID = rs(FLD_ID)
    rs.MoveNext
  Wend
  rs.Close
  RecRead = tArySrc
End Function

Private Function NextAryInfo(iNum As Long, tPosSrc As PosData, tArySrc() As AryData) As Long
  Dim i As Long

  NextAryInfo = 0
  With tPosSrc
    .mv_Apos = .mv_Apos + 1
    If (.mv_Apos > .mv_Bpos) Then Exit Function
    If (tArySrc(.mv_Apos).F1 > iNum) Then Exit Function
    While (tArySrc(.mv_Bpos).F1 > iNum)
      .mv_Bpos = .mv_Bpos - 1
    Wend
  
    i = .mv_Bpos - .mv_Apos + 1
    Select Case i
      Case 1: If (tArySrc(.mv_Apos).F1 <> iNum) Then Exit Function
      Case 2
        If (tArySrc(.mv_Apos).F1 <> iNum) Then
          If ((tArySrc(.mv_Apos).F1 + tArySrc(.mv_Bpos).F1) > iNum) Then
            If (tArySrc(.mv_Bpos).F1 <> iNum) Then Exit Function
            .mv_Apos = .mv_Bpos
            i = 1
          End If
        End If
    End Select
    NextAryInfo = i
  End With
End Function


Private Sub ReCallSum(iNum As Long, tPosSrc As PosData, tArySrc() As AryData, tAryDest() As AryData)
  Dim tPosWsrc As PosData, tPosToSrc As PosData
  Dim iNumNew As Long
  Dim i As Long, j As Long
  Dim sS As String

  With tPosSrc
    j = 0
    For i = .mv_Apos To .mv_Bpos
      j = j + tArySrc(i).F1
    Next
  End With
  If ((j = 0) Or (iNum > j)) Then Exit Sub

  tPosWsrc = tPosSrc
  With tPosWsrc
    .fx_pos = .fx_pos + 1
    Do While (.mv_Apos <= .mv_Bpos)
      iNumNew = iNum - tArySrc(.mv_Apos).F1
      If (iNumNew < 0) Then Exit Do
      tAryDest(.fx_pos) = tArySrc(.mv_Apos)
      If (iNumNew = 0) Then
        sS = ""
        For i = 0 To .fx_pos
          sS = sS & "," & tAryDest(i).ID
        Next
      ' ここで毎回 Debug.Print してたら遅すぎたので、文字列だけ作って Debug.Print は後
        sMsg = sMsg & vbCrLf & "ID: " & Mid(sS, 2)
        iCnt = iCnt + 1
      Else
        tPosToSrc = tPosWsrc
        If (NextAryInfo(iNumNew, tPosToSrc, tArySrc) <> 0) Then
          Call ReCallSum(iNumNew, tPosToSrc, tArySrc, tAryDest)
        End If
      End If
      .mv_Apos = .mv_Apos + 1
    Loop
  End With
End Sub

Public Sub SumSearch(iNum As Long)
  Dim tArySrc() As AryData, tAryDest() As AryData
  Dim tPosSrc As PosData
  Dim st As Single

  st = Timer
  sMsg = ""
  iCnt = 0
  tArySrc = RecRead("T1")
  If (tArySrc(0).ID = 0) Then Exit Sub
  tAryDest = tArySrc
  With tPosSrc
    .fx_pos = -1
    .mv_Apos = 0
    .mv_Bpos = UBound(tArySrc)
  End With
  Call ReCallSum(iNum, tPosSrc, tArySrc, tAryDest)
  Debug.Print Mid(sMsg, Len(vbCrLf) + 1)
  Debug.Print ">>> " & iNum & " の件数(" & iCnt & ")" _
        & " 処理時間:" & Format(Timer - st, "0.000\秒")
End Sub

Public Sub Sample()
  Dim sS As String

  Do While (1)
    sS = InputBox("合計値を入力してください", "パターン検索", "1574")
    If (Len(sS) = 0) Then Exit Do
    If (Not IsNumeric(sS)) Then Exit Do
    Call SumSearch(CLng(sS))
  Loop
End Sub

 

※ いや、こういう考え方した方が良いよ・・・・等、教えてください。

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt126_2000.zipkEnt126_2003.zipkEnt126_2007.zip
 サイズ 212,003204,856215,667
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化


付録は以下
作成時資料
kEnt126.zip
483,297
※ ファイルは zip 形式
※ 処理イメージの PDF と、「T3」の内容(xlsファイル)
※ 追記 4/21 の変更後の結果「T4」(xlsファイル)を追加

関連記事

2012/04/20

Category: やってみる

TB: 0  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/126-4aaa98a8
この記事にトラックバックする(FC2ブログユーザー)

top △


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