スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

再帰処理にはまる(その3) 


anグループ記号flg
1WXT
2WXR
3WXZ
4STJ
5XYM
6FGS
7FGX
8OPQ
9OPI
10RSA
11RSC
12RSJ
13RSM
14BCY
15EFJ
16EFP
17EFN
18EFB
19KLT
20JKA
21JKM
22JKI

というテーブル「TA」があったとして、
まず一回目、「記号」に "A" があるグループの「flg」を "×" にします。
二回目、「flg」が "×" になった「記号」を含むグループの「flg」を "×" にします。
三回目、二回目と同様に「flg」が "×" になった「記号」を含むグループの「flg」を "×" にします。

とした場合、どうしましょうか・・・・

サンプルファイルは 再帰処理にはまる(その1) にあります
再帰処理にはまる(その2) も読んでいただければと
 

1)ベタで考える【標準モジュール:Pat3n】


1-1)都度対象を求める

直接テーブルの「flg」を更新するものになります。
一回ごとに、対象のグループを求めて「flg」を更新します。
一回目は、記号 Like '%A%' で対象グループを求めて更新
(ADOでやっているので % を使用)
二回目以降は、「flg」が "×" になっているグループが持つ「記号」を求め、
その「記号」を持つグループの「flg」を "×" に・・・・・
記号 IN ( XXXXXX ) の XXXXXX 部分は、ADO の GetString を使用
二回、三回と処理していくうちに対象の記号に変化がない場合は、処理をやめるように・・・
この判別に Dictionary を使用

Public Sub Sample1()
  Dim dic As Object
  Dim rs As New ADODB.Recordset
  Dim sSql As String
  Dim sS As String
  Dim i As Long, j As Long
  Const sAdoDao As String = "%"
  Const sChkChg As String = "flg = '×'"

  Const iCount As Long = 3


  DoCmd.Close acTable, sTable, acSaveNo
  Call Pat3m.ResetTA
  Set dic = CreateObject("Scripting.Dictionary")

  sS = "A"
  For i = 1 To iCount
    If (Len(sS) > 0) Then
      sS = "Like '" & sAdoDao & sS & sAdoDao & "'"
    Else
      rs.Source = "SELECT DISTINCT 記号 FROM " & sTable & " WHERE グループ IN " _
            & "(SELECT グループ FROM " & sTable & " WHERE " & sChkChg & ");"
      rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
      If (Not rs.EOF) Then sS = Trim(rs.GetString(adClipString, , "", " "))
      rs.Close
      If (Len(sS) = 0) Then Exit For
      j = dic.Count
      dic.Item(sS) = Null
      If (dic.Count = j) Then Exit For
      sS = "IN ('" & Replace(sS, " ", "','") & "')"
    End If
    sSql = "UPDATE " & sTable & " SET " & sChkChg & " WHERE グループ IN " _
          & "(SELECT グループ FROM " & sTable & " WHERE 記号 " & sS & ");"
    CurrentProject.Connection.Execute sSql
    sS = ""
  Next
  Set dic = Nothing
  DoCmd.OpenTable sTable
End Sub

 

1-2)クエリを作成して「flg」を求める

直接テーブルの「flg」をいじるのは簡単に出来ましたが、クエリでやってみますか・・・ということで
抽出の考え方は同じで、サブクエリをネストしていくものになります。
三回位までしか確認していませんが、どの程度ネスト出来るのでしょうか・・・・
既に作られているクエリ「Q_TA」は三回繰り返すものとなっています。

Public Sub Sample2()
  Dim sSql As String
  Dim sS As String
  Dim i As Long
  Const sAdoDao As String = "*"
  Const sQuery As String = "Q_TA"

  Const iCount As Long = 3

  sSql = "SELECT DISTINCT '0' AS グループ FROM " & sTable
  sS = "Like '" & sAdoDao & "A" & sAdoDao & "'"
  For i = 1 To iCount
    sSql = "SELECT DISTINCT グループ FROM " & sTable & " WHERE 記号 " & sS
    sS = "IN (SELECT 記号 FROM " & sTable & " WHERE グループ IN (" & Replace(sSql, "DISTINCT ", "") & "))"
  Next
  sSql = "SELECT Q1.グループ, Q1.記号, IIF(IsNull(Q2.グループ),'○','×') AS flg FROM " & sTable & " AS Q1 " _
      & "LEFT JOIN (" & sSql & ") AS Q2 ON Q1.グループ = Q2.グループ;"

  On Error Resume Next
  DoCmd.Close acQuery, sQuery, acSaveNo
  With CurrentDb
    .QueryDefs.Delete sQuery
    .CreateQueryDef sQuery, sSql
    .QueryDefs.Refresh
  End With
  RefreshDatabaseWindow
  DoCmd.OpenQuery sQuery
End Sub

 
  Const iCount As Long = 3

  sSql = "SELECT DISTINCT '0' AS グループ FROM " & sTable
部分での sSql 記述は、不正な iCount を設定された時に、正常な表示だけでもしましょうか・・・
・・・・程度のものです。
iCount >= 1 の設定では不要な行になります。


2)再帰処理で考える【標準モジュール:Pat3r】


2-1)Clone を作成して「記号」「グループ」を辿る

クエリで再帰処理?その2 での考え方に近いものとなります。
「記号」で絞り込んだものから「グループ」を求め、その「グループ」にある「記号」を求め直し、
その「グループ」をさらに処理対象とする・・・・・
この時、どの「グループ」を処理したのか管理するものに Dictionary を使用します。
その際のキーは「グループ名」で、Item にネスト位置情報を用います。
「記号」「グループ」を辿っていく際、辿り順によっては処理するネストが異なってくる場合があります。
このグループは既に処理しているけど、深いネストの時のものだったのね。
重複する処理になるけど浅いネストとしてもう一度やり直しましょうか・・・・・

Dim dic As Object

Private Sub ReCallRs(iNst As Long, rsP As ADODB.Recordset)
  Dim rs As ADODB.Recordset
  Dim rs2 As ADODB.Recordset
  Dim sS As String

  If (iNst <= 0) Then Exit Sub
  sS = rsP("グループ")
  If (dic.exists(sS)) Then
    If (dic.Item(sS) >= iNst) Then Exit Sub
  End If
  dic.Item(sS) = iNst
  Set rs = rsP.Clone
  Set rs2 = rs.Clone
  rs.Filter = "グループ = '" & sS & "'"
  While (Not rs.EOF)
    rs("flg") = "×"
    rs.Update
    If (iNst > 1) Then
      rs2.Filter = "記号 = '" & rs("記号") & "'"
      While (Not rs2.EOF)
        Call ReCallRs(iNst - 1, rs2)
        rs2.MoveNext
      Wend
    End If
    rs.MoveNext
  Wend
  rs2.Close
  rs.Close
  Set rs2 = Nothing
  Set rs = Nothing
End Sub

Public Sub Sample1()
  Dim rs As New ADODB.Recordset

  Const iCount As Long = 3


  DoCmd.Close acTable, sTable, acSaveNo
  Call Pat3m.ResetTA
  Set dic = CreateObject("Scripting.Dictionary")

  rs.Open sTable, CurrentProject.Connection, adOpenStatic, adLockOptimistic
  rs.Filter = "記号 Like '%A%'"
  While (Not rs.EOF)
    Call ReCallRs(iCount, rs)
    rs.MoveNext
  Wend
  rs.Close

  Set dic = Nothing
  DoCmd.OpenTable sTable
End Sub

 


3)テーブル「TA」のデータを作る【標準モジュール:Pat3m】


テストパターンがおもわしくない場合、ある程度の指定でデータを作成するものを作ってみました。
そこそこ動くと思いますが、最悪、無限ループになることがあるかも・・・・

Public Const sTable As String = "TA"

Public Sub DataMakeTA()
  Dim dic As Object, dic2 As Object
  Dim sMrk As String
  Dim sG As String, sM As String
  Dim iGrpLen As Long, iMrkLen As Long
  Dim i As Long, j As Long, k As Long
  Dim sSql As String, sS As String
  Dim bNoneA As Boolean

  Const sGrp As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  Const iGrpNum As Long = 10   ' 作成するグループの個数(推奨:20以下)
  Const iMaxGrpLen As Long = 2  ' グループ名の最大文字数
  Const iGrpEnt As Long = 4   ' 1グループのデータ最大数
  Const iMaxMrk As Long = 40   ' 記号を作る参照文字長
  Const iMaxMrkLen As Long = 1  ' 記号の最大文字数
  Const sFixChr As String = "A" ' 最低限必要な文字

  DoCmd.Close acTable, sTable, acSaveNo
  Set dic = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  Randomize
  bNoneA = True
  While (bNoneA)
    sMrk = String(iMaxMrk, "a")
    For i = 1 To iMaxMrk
      Mid(sMrk, i, 1) = Mid(sGrp, Int(Rnd() * Len(sGrp)) + 1, 1)
    Next

    With CurrentProject.Connection
      .Execute "DELETE * FROM " & sTable & ";"
      dic.RemoveAll
      For i = 1 To iGrpNum
        Do
'          iGrpLen = Int(Rnd() * iMaxGrpLen) + 1
          iGrpLen = iMaxGrpLen ' 現在固定長(可変は上記)
          k = dic.Count
          sG = Mid(sGrp, Int(Rnd() * (Len(sGrp) - (iGrpLen - 1))) + 1, iGrpLen)
          dic.Item(sG) = Null
        Loop While (dic.Count = k)
        sS = "INSERT INTO " & sTable & "(グループ, 記号) VALUES ('" & sG & "','"
        dic2.RemoveAll
        For j = 0 To Int(Rnd() * iGrpEnt)
          Do
            iMrkLen = Int(Rnd() * iMaxMrkLen) + 1
            sM = Mid(sMrk, Int(Rnd() * (iMaxMrk - (iMrkLen - 1))) + 1, iMrkLen)
            k = dic2.Count
            dic2.Item(sM) = Null
          Loop While (dic2.Count = k)
          If (sM Like "*" & sFixChr & "*") Then bNoneA = False
          sSql = sS & sM & "');"
          .Execute sSql
        Next
      Next
    End With
  Wend
  Set dic = Nothing
  Set dic2 = Nothing
  DoCmd.OpenTable sTable
End Sub



Public Sub ResetTA()
  CurrentProject.Connection.Execute "UPDATE " & sTable & " SET flg = '○';"
End Sub

 
関連記事

2012/03/12

Category: やってみる

TB: 0  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △

トラックバック

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

top △


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