階層構造テーブル群でのレコード複製
たいそうな標題にしましたけど・・・・
過去記事でも部品的なものは書いていたかと思います。
1レコードのコピー とか データの転送(再採番あり) など・・・・
階層構造のテーブル群でのフォーム構成・・・っていうのでは
【帳票フォーム+サブの構成】x2(ネストはどうよ その2)
というのも書いてみたりしてました。
今回は、レコード複製する部分だけを考えてみました。
「T見積」「T見積明細」「T見積内訳」の3つのテーブルがあるとします。
テーブル「T見積」の構成
フィールド名 |
---|
見積CD 主キー |
見積日 |
担当者CD |
得意先CD |
備考 |
テーブル「T見積明細」の構成
フィールド名 |
---|
見積明細CD 主キー |
見積CD |
明細行番号 |
大分類CD |
見積明細金額 |
備考 |
テーブル「T見積内訳」の構成
フィールド名 |
---|
見積内訳CD 主キー |
見積明細CD |
内訳行番号 |
名称 |
規格 |
単位 |
数量 |
単価 |
備考 |
これらテーブルのリレーションシップは以下の様になります。

※ **CD とか **番号 とかのデータ型は長整数
この状態の時に、「T見積」の「見積CD」が 2 のものを複製する・・・・したい・・・
まず、各テーブルの主キーは自分で採番するものとします。
で、処理を考えていくわけですが・・・・
・これらテーブルでの専用にする
・これらテーブルの構成を元に他でも使えるようにしておく
・等々
私の場合・・・・極力他でも使える/使い回しできるものを・・・を考えます。
ということで・・・・・
「テーブル」「採番するフィールド」「抽出する条件のフィールド」「固定的に設定するフィールド」
の4つを与える事にします。
テーブル「T見積」に対しての設定を記述してみると
Array("T見積", "見積CD", "見積CD", Null)
「T見積」では、「見積CD」を採番して(「見積CD」を条件に抽出後に)固定的に設定すのは無いよ・・・
テーブル「T見積明細」に対しての設定を記述してみると
Array("T見積明細", "見積明細CD", "見積CD", "見積CD")
「T見積明細」では、「見積明細CD」を採番して(「見積CD」を条件に抽出後に)
「見積CD」を固定的に設定してよ・・・
※ ここでは、抽出条件での「見積CD」は元の値で、固定的「見積CD」の値は新採番後のものになります。
で、3つのテーブルをまとめて記述すると
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
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 で抽出して処理してちょうだい・・・
(ここでの3つ目の引数はダミー扱いになります)
(後の処理になりますが、「固定的に設定するフィールド」が 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
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
対象のレコードを抽出して・・・
レコード数分コピーします。
コピーした時に新採番した値を覚えておいて・・・
まだ次のテーブルを処理する必要があったら・・・再帰呼び出しで・・・
つまり、親にあたるテーブルの1レコードごとに、その下にぶら下がるものを辿りながら複製していきます。
ここで、レコード数分・・・・ For i = 1 To rs.RecordCount でループする様にしています。
通常であれば While (Not rs.EOF) 等で処理すると思いますが・・・・
コピーの仕方・・・・これが影響します。
コピーの方法として、現 rs の Clone を作成し、そこに AddNew します。
これは rs の最後に1レコード追加され・・・レコード数は、その分増えます。
つまり、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
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
1レコードをコピーする部分は、フィールド名・・・とか、順・・・とか・・・
面倒くさいので、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
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
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
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
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」というフィールド名は、どのテーブルでも同じ・・・・
※※ エラー処理は入れてません
※※ エラー処理も含め、こうした方が・・・こう考えた方が・・・・教えてください
なお、サンプルファイルはいらないのかと思いましたが・・・・
データは、数件適当に入れてます。
いろいろといじってみてください。
サンプルは以下 | ||||||||||||
| ||||||||||||
※ ファイルは zip 形式 | ||||||||||||
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化 |
- 関連記事
-
- 帳票フォームにサブフォームを組み込んでみた (2011/06/26)
- 深夜時間の計算 (2013/09/15)
- Excel への自力出力例(行・縦計算式挿入) (2012/10/09)
- リストボックス操作の模索 (2012/03/31)
- 予定表 (2013/10/14)
- 同時入力したい (2013/09/08)
- 営業日のカウント (2014/04/06)
- 検索用途コンボの4階層連携 (2014/07/06)
- サブフォームのFilter (2011/10/10)
- 採番する (2011/11/26)
- 取り込みながらのテーブル分割と関連付け (2014/08/23)
- Excel VBA をやってみた その16 (2015/05/26)
- どの方法が良いのだろう (2012/05/14)
2013/06/09
Category: サンプルかな
TB: -- /
CM: 0
この記事に対するコメント
| h o m e |