～ kiku tips ～　階層構造テーブル群でのレコード複製

スポンサーサイト

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

--/--/--

TB： -- / CM： --

たいそうな標題にしましたけど････
過去記事でも部品的なものは書いていたかと思います。
１レコードのコピー　とか　データの転送（再採番あり）　など････

階層構造のテーブル群でのフォーム構成･･･っていうのでは
【帳票フォーム＋サブの構成】ｘ２（ネストはどうよ　その２）
というのも書いてみたりしてました。

今回は、レコード複製する部分だけを考えてみました。
「T見積」「T見積明細」「T見積内訳」の３つのテーブルがあるとします。

テーブル「T見積」の構成

フィールド名
見積CD 主キー
見積日
担当者CD
得意先CD
備考

テーブル「T見積明細」の構成

フィールド名
見積明細CD 主キー
見積CD
明細行番号
大分類CD
見積明細金額
備考

テーブル「T見積内訳」の構成

フィールド名
見積内訳CD 主キー
見積明細CD
内訳行番号
名称
規格
単位
数量
単価
備考

これらテーブルのリレーションシップは以下の様になります。

※ **CD とか **番号とかのデータ型は長整数

この状態の時に、「T見積」の「見積CD」が 2 のものを複製する････したい･･･

まず、各テーブルの主キーは自分で採番するものとします。
で、処理を考えていくわけですが････
・これらテーブルでの専用にする
・これらテーブルの構成を元に他でも使えるようにしておく
・等々
私の場合････極力他でも使える/使い回しできるものを･･･を考えます。
ということで･････

「テーブル」「採番するフィールド」「抽出する条件のフィールド」「固定的に設定するフィールド」
の４つを与える事にします。
テーブル「T見積」に対しての設定を記述してみると

Array("T見積", "見積CD", "見積CD", Null)

「T見積」では、「見積CD」を採番して（「見積CD」を条件に抽出後に）固定的に設定すのは無いよ･･･

テーブル「T見積明細」に対しての設定を記述してみると

Array("T見積明細", "見積明細CD", "見積CD", "見積CD")

「T見積明細」では、「見積明細CD」を採番して（「見積CD」を条件に抽出後に）
「見積CD」を固定的に設定してよ･･･
※　ここでは、抽出条件での「見積CD」は元の値で、固定的「見積CD」の値は新採番後のものになります。

で、３つのテーブルをまとめて記述すると

Dim vTbl As Variant

Public Sub ChainCopy(iSrc As Long)
　　vTbl = Array( _
　　　　　　　　Array("T見積", "見積CD", "見積CD", Null), _
　　　　　　　　Array("T見積明細", "見積明細CD", "見積CD", "見積CD"), _
　　　　　　　　Array("T見積内訳", "見積内訳CD", "見積明細CD", "見積明細CD") _
　　　　　　)

　　Call ChainCopySub(0, iSrc, iSrc)
End Sub

そう･･･メインで呼ぶ関数を ChainCopy としました。
見積CD = 2 を複製したい時には　Call ChainCopy(2) のように･･･
で、本処理する関数を vTbl配列の 0 番目を iSrc で抽出して処理してちょうだい･･･
（ここでの３つ目の引数はダミー扱いになります）
（後の処理になりますが、「固定的に設定するフィールド」が Null なら参照しない様になってます）

本処理 ChainCopySub では

Private Sub ChainCopySub(iNum As Long, iOld As Long, iNew As Long)
　　Dim rs As ADODB.Recordset
　　Dim i As Long, iR As Long

　　Set rs = RecOpen(iNum, iOld)
　　For i = 1 To rs.RecordCount
　　　　iR = OneCopy(rs, iNum, iNew)
　　　　If (iNum < UBound(vTbl)) Then
　　　　　　Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), iR)
　　　　End If
　　　　rs.MoveNext
　　Next
　　rs.Close
　　Set rs = Nothing
End Sub

対象のレコードを抽出して･･･
レコード数分コピーします。
コピーした時に新採番した値を覚えておいて･･･
まだ次のテーブルを処理する必要があったら･･･再帰呼び出しで･･･
つまり、親にあたるテーブルの１レコードごとに、その下にぶら下がるものを辿りながら複製していきます。

ここで、レコード数分････　For i = 1 To rs.RecordCount　でループする様にしています。
通常であれば While (Not rs.EOF)　等で処理すると思いますが････
コピーの仕方････これが影響します。
コピーの方法として、現 rs の Clone を作成し、そこに AddNew します。
これは rs の最後に１レコード追加され･･･レコード数は、その分増えます。
つまり、rs.EOF 判別では･･･増えた分も順に･･･順に･･で、無限ループに陥ります。
初期に抽出した分････これだけを処理したいので For を使うように･･･
で、For では rs.RecordCount が必要なので、rs.Open 時 adOpenForwardOnly は使えない･･･
また、Clone を使いたいので adOpenForwardOnly は使えない････
で、で、rs.Open 時には　adOpenStatic　を指定することに･･････

Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
　　Dim rs As ADODB.Recordset
　　Dim sSql As String
　　Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

　　Set rs = New ADODB.Recordset
　　sSql = sSqlBase
　　sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
　　sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
　　sSql = Replace(sSql, "{%3}", iOld)
　　sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
　　rs.Source = sSql
　　rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
　　Set RecOpen = rs
End Function

１レコードをコピーする部分は、フィールド名･･･とか、順･･･とか･･･
面倒くさいので、Clone を作って、添え字で単純ループする様に･･･
（今回 Clone 部分を With 記述してみた）

Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
　　　　　　　　　　　　　　iFixVal As Long) As Long
　　Dim iM As Long, i As Long

　　If (rs.EOF) Then Exit Function
　　iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
　　With rs.Clone
　　　　.AddNew
　　　　For i = 0 To rs.Fields.Count - 1
　　　　　　.Fields(i) = rs(i)
　　　　Next
　　　　.Fields(vTbl(iNum)(1)) = iM
　　　　If (Not IsNull(vTbl(iNum)(3))) Then .Fields(vTbl(iNum)(3)) = iFixVal
　　　　.Update
　　　　.Close
　　End With
　　OneCopy = iM
End Function

これらは、標準モジュール「Module1」に記述してます。
全記述は以下

Dim vTbl As Variant

Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
　　　　　　　　　　　　　　iFixVal As Long) As Long
　　Dim iM As Long, i As Long

　　If (rs.EOF) Then Exit Function
　　iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
　　With rs.Clone
　　　　.AddNew
　　　　For i = 0 To rs.Fields.Count - 1
　　　　　　.Fields(i) = rs(i)
　　　　Next
　　　　.Fields(vTbl(iNum)(1)) = iM
　　　　If (Not IsNull(vTbl(iNum)(3))) Then .Fields(vTbl(iNum)(3)) = iFixVal
　　　　.Update
　　　　.Close
　　End With
　　OneCopy = iM
End Function

Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
　　Dim rs As ADODB.Recordset
　　Dim sSql As String
　　Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

　　Set rs = New ADODB.Recordset
　　sSql = sSqlBase
　　sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
　　sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
　　sSql = Replace(sSql, "{%3}", iOld)
　　sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
　　rs.Source = sSql
　　rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
　　Set RecOpen = rs
End Function

Private Sub ChainCopySub(iNum As Long, iOld As Long, iNew As Long)
　　Dim rs As ADODB.Recordset
　　Dim i As Long, iR As Long

　　Set rs = RecOpen(iNum, iOld)
　　For i = 1 To rs.RecordCount
　　　　iR = OneCopy(rs, iNum, iNew)
　　　　If (iNum < UBound(vTbl)) Then
　　　　　　Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), iR)
　　　　End If
　　　　rs.MoveNext
　　Next
　　rs.Close
　　Set rs = Nothing
End Sub

Public Sub ChainCopy(iSrc As Long)
　　vTbl = Array( _
　　　　　　　　Array("T見積", "見積CD", "見積CD", Null), _
　　　　　　　　Array("T見積明細", "見積明細CD", "見積CD", "見積CD"), _
　　　　　　　　Array("T見積内訳", "見積内訳CD", "見積明細CD", "見積明細CD") _
　　　　　　)

　　Call ChainCopySub(0, iSrc, iSrc)
End Sub

Public Sub test()
　　Call ChainCopy(2)
End Sub

ここで、確認用の test を実行してみると以下の様な感じで表示され、複製はうまくいったようです。

ここまでで、一応想定したテーブル群での複製はできるようになりました。

ただ最近の質問にあったのは、テーブル「T見積内訳」の構成に ★ 部分が存在していました。

フィールド名
見積内訳CD 主キー
見積CD ★
見積明細CD
内訳行番号
名称
規格
単位
数量
単価
備考

「T見積」「T見積明細」「T見積内訳」を「T見積Z」「T見積明細Z」「T見積内訳Z」名でコピーし、
「T見積内訳Z」を同じになるように修正します。
そこで、標準モジュール「Module1」のものを「Module2」にコピーして修正を掛けます。

Dim vTbl As Variant

Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
　　　　　　　　　　　　　　vFixVal As Variant) As Long
　　Dim iM As Long, i As Long, j As Long
　　Dim v As Variant

　　If (rs.EOF) Then Exit Function
　　iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
　　With rs.Clone
　　　　.AddNew
　　　　For i = 0 To rs.Fields.Count - 1
　　　　　　.Fields(i) = rs(i)
　　　　Next
　　　　.Fields(vTbl(iNum)(1)) = iM
　　　　v = vTbl(iNum)(3)
　　　　If (IsArray(v)) Then
　　　　　　For j = 0 To UBound(v)
　　　　　　　　.Fields(v(j)) = vFixVal(j)
　　　　　　Next
　　　　End If
　　　　.Update
　　　　.Close
　　End With
　　OneCopy = iM
End Function

Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
　　Dim rs As ADODB.Recordset
　　Dim sSql As String
　　Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

　　Set rs = New ADODB.Recordset
　　sSql = sSqlBase
　　sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
　　sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
　　sSql = Replace(sSql, "{%3}", iOld)
　　sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
　　rs.Source = sSql
　　rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
　　Set RecOpen = rs
End Function

Private Sub ChainCopySub(iNum As Long, iOld As Long, vNew As Variant)
　　Dim rs As ADODB.Recordset
　　Dim i As Long, j As Long, iR As Long
　　Dim v As Variant, vPrm As Variant

　　Set rs = RecOpen(iNum, iOld)
　　For i = 1 To rs.RecordCount
　　　　iR = OneCopy(rs, iNum, vNew)
　　　　If (iNum < UBound(vTbl)) Then
　　　　　　v = vTbl(iNum + 1)(3)
　　　　　　If (IsArray(v)) Then
　　　　　　　　ReDim vPrm(UBound(v))
　　　　　　　　With rs.Clone
　　　　　　　　　　.MoveLast　' コピーした最新のものは最後にあるはず･･･そこから値を入手
　　　　　　　　　　For j = 0 To UBound(v)
　　　　　　　　　　　　vPrm(j) = .Fields(v(j))
　　　　　　　　　　Next
　　　　　　　　　　.Close
　　　　　　　　End With
　　　　　　End If
　　　　　　Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), vPrm)
　　　　End If
　　　　rs.MoveNext
　　Next
　　rs.Close
　　Set rs = Nothing
End Sub

Public Sub ChainCopy(iSrc As Long)
　　vTbl = Array( _
　　　　　　　　Array("T見積Z", "見積CD", "見積CD", _
　　　　　　　　　　Null), _
　　　　　　　　Array("T見積明細Z", "見積明細CD", "見積CD", _
　　　　　　　　　　Array("見積CD")), _
　　　　　　　　Array("T見積内訳Z", "見積内訳CD", "見積明細CD", _
　　　　　　　　　　Array("見積CD", "見積明細CD")) _
　　　　　　)

　　Call ChainCopySub(0, iSrc, Null)
End Sub

Public Sub test()
　　Call ChainCopy(2)
End Sub

※　テーブル名が変わった････云々･･･
　vTbl に設定する部分を変更するだけですね････（固定値が複数になったところを除けば）

それはそうと･･･XX 番の見積CD を複製したら、YY番･･･これ、知りたい/通知したい･･･かな？
ということで････標準モジュール「Module2」のものを「Module3」にコピーして修正を掛けます。

Dim vTbl As Variant

Private Function OneCopy(rs As ADODB.Recordset, iNum As Long, _
　　　　　　　　　　　　　　vFixVal As Variant) As Long
　　Dim iM As Long, i As Long, j As Long
　　Dim v As Variant

　　If (rs.EOF) Then Exit Function
　　iM = Nz(DMax(vTbl(iNum)(1), vTbl(iNum)(0)), 0) + 1
　　With rs.Clone
　　　　.AddNew
　　　　For i = 0 To rs.Fields.Count - 1
　　　　　　.Fields(i) = rs(i)
　　　　Next
　　　　.Fields(vTbl(iNum)(1)) = iM
　　　　v = vTbl(iNum)(3)
　　　　If (IsArray(v)) Then
　　　　　　For j = 0 To UBound(v)
　　　　　　　　.Fields(v(j)) = vFixVal(j)
　　　　　　Next
　　　　End If
　　　　.Update
　　　　.Close
　　End With
　　OneCopy = iM
End Function

Private Function RecOpen(iNum As Long, iOld As Long) As ADODB.Recordset
　　Dim rs As ADODB.Recordset
　　Dim sSql As String
　　Const sSqlBase As String = "SELECT * FROM {%1} WHERE {%2} = {%3} ORDER BY {%4};"

　　Set rs = New ADODB.Recordset
　　sSql = sSqlBase
　　sSql = Replace(sSql, "{%1}", vTbl(iNum)(0))
　　sSql = Replace(sSql, "{%2}", vTbl(iNum)(2))
　　sSql = Replace(sSql, "{%3}", iOld)
　　sSql = Replace(sSql, "{%4}", vTbl(iNum)(1))
　　rs.Source = sSql
　　rs.Open , CurrentProject.Connection, adOpenStatic, adLockOptimistic
　　Set RecOpen = rs
End Function

Private Function ChainCopySub(iNum As Long, iOld As Long, vNew As Variant) As Long
　　Dim rs As ADODB.Recordset
　　Dim i As Long, j As Long, iR As Long
　　Dim v As Variant, vPrm As Variant

　　Set rs = RecOpen(iNum, iOld)
　　For i = 1 To rs.RecordCount
　　　　iR = OneCopy(rs, iNum, vNew)
　　　　If (iNum < UBound(vTbl)) Then
　　　　　　v = vTbl(iNum + 1)(3)
　　　　　　If (IsArray(v)) Then
　　　　　　　　ReDim vPrm(UBound(v))
　　　　　　　　With rs.Clone
　　　　　　　　　　.MoveLast
　　　　　　　　　　For j = 0 To UBound(v)
　　　　　　　　　　　　vPrm(j) = .Fields(v(j))
　　　　　　　　　　Next
　　　　　　　　　　.Close
　　　　　　　　End With
　　　　　　End If
　　　　　　Call ChainCopySub(iNum + 1, rs(vTbl(iNum + 1)(2)), vPrm)
　　　　End If
　　　　rs.MoveNext
　　Next
　　rs.Close
　　Set rs = Nothing
　　ChainCopySub = iR
End Function

Public Function ChainCopy(iSrc As Long) As Long
　　vTbl = Array( _
　　　　　　　　Array("T見積Z", "見積CD", "見積CD", _
　　　　　　　　　　Null), _
　　　　　　　　Array("T見積明細Z", "見積明細CD", "見積CD", _
　　　　　　　　　　Array("見積CD")), _
　　　　　　　　Array("T見積内訳Z", "見積内訳CD", "見積明細CD", _
　　　　　　　　　　Array("見積CD", "見積明細CD")) _
　　　　　　)

　　ChainCopy = ChainCopySub(0, iSrc, Null)
End Function

Public Sub test()
　　Debug.Print ChainCopy(2)
End Sub

言い忘れていましたが････各テーブル間で値を引き継ぐもののフィールド名は親/子とも同じ････
これが前提であります。
例えば「見積CD」というフィールド名は、どのテーブルでも同じ････

※※ エラー処理は入れてません

※※ エラー処理も含め、こうした方が･･･こう考えた方が････教えてください

なお、サンプルファイルはいらないのかと思いましたが････
データは、数件適当に入れてます。
いろいろといじってみてください。

サンプルは以下

バージョン	2000	2003 (2002)	2007
ファイル	kEnt164_2000.zip	kEnt164_2003.zip	kEnt164_2007.zip
サイズ	31,709	31,858	34,848

※ ファイルは zip 形式

※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2013/06/09

Category: サンプルかな

TB： -- / CM： 0

top △

« 初の回答ブロック
 Excel へのデータ転記 »

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

top △

コメントの投稿

top △

| h o m e |

日	月	火	水	木	金	土
-	1	2	3	4	5	6
7	8	9	10	11	12	13
14	15	16	17	18	19	20
21	22	23	24	25	26	27
28	29	30	31	-	-	-

～ kiku tips ～

Access VBA が使えたら･･･

スポンサーサイト

階層構造テーブル群でのレコード複製

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

コメントの投稿

ぶつぶつ

カレンダー

全記事表示リンク

最新記事

カテゴリ

カウンター

自動ＲＳＳ表示機能付きリンク

～ kiku tips ～

Access VBA が使えたら ･･･

スポンサーサイト nw(&#45;&#45;,&#45;&#45;,&#45;&#45;,&#45;&#45;)

階層構造テーブル群でのレコード複製 nw(2013,06,09,13)

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

コメントの投稿

ぶつぶつ

カレンダー

全記事表示リンク

最新記事

カテゴリ

カウンター

自動ＲＳＳ表示機能付きリンク

　　　　Access VBA が使えたら･･･

スポンサーサイト

階層構造テーブル群でのレコード複製