みなさん、こんにちは。
今回も先日に続き EXCEL VBA についてです。
シートのデータを RecordSet に取り込んで利用されている方も多いかと思います。
Dim dbRes As ADODB.Recordset
Set dbRes = New ADODB.Recordset
dbRes.Open SQLstr, ShtConn, adOpenKeyset, adLockOptimistic
'何かRecordSetを操作する処理を行う
dbRes.MoveFirst
Do Until dbRes.EOF
dbRes.MoveNext
Loop
dbRes.Close
こんな感じでしょうか。
RecordSet を Close する前に希望の処理を記述します。
この場合、dbRes.MoveNext です。
しかし Close した後では RecordSet は使用できなくなります。
Dim dbRes As ADODB.Recordset
Set dbRes = New ADODB.Recordset
dbRes.Open SQLstr, ShtConn, adOpenKeyset, adLockOptimistic
dbRes.Close
'何かRecordSetを操作する処理を行う
dbRes.MoveFirst
Do Until dbRes.EOF
dbRes.MoveNext
Loop
実行時エラー'3704':
オブジェクトが閉じている場合は、操作は許可されません。
閉じる前に全ての処理を記述できればよいのですが、そうもいきません。
最悪、Close しないで処理を続けても動くとは思いますが、なんか気持ち悪いですね。
それにRecodeSet は任意のタイミングで操作したい。
Dim cloneRs As ADODB.Recordset
Set cloneRs = dbRes.clone
として dbRes を cloneRs にコピーをして cloneRs を使いまわそうと思っても、オリジナルの dbRes を Close すると cloneRs まで同じタイミングで破棄されるので結局意味がありません。
2次元配列かRecordSetを作成してレコードごとに書き出していくしかないようです。
どうせなら RecordSet に書き出すようにしてみます。
(cloneRsを変数宣言していますが実際は引数で与えます)
Dim cloneRs As ADODB.Recordset
Dim fld As ADODB.Field
Set cloneRs = New ADODB.Recordset
For Each fld In dbRes.Fields
cloneRs.Fields.Append fld.Name, fld.Type, fld.DefinedSize,
fld.Attributes
Next
cloneRs.Open
Do Until dbRes.EOF
cloneRs.AddNew
For Each fld In dbRes.Fields
cloneRs.Fields(fld.Name).Value = fld.Value
Next
cloneRs.Update
dbRes.MoveNext
Loop
これで、dbRes を Close しても、cloneRs は、使用ができます。
下記が、コードとなります。
cnStr は、起動時並びにファイルを「名前を付 けて保存」した際に、再読み込みできるよう別プロシージャにしました。
Option Explicit
Public cnStr As String
Sub GetCnStr() '接続文字列の作成
Dim PathStr As String
PathStr = ThisWorkbook.Path & "\" & ThisWorkbook.Name
cnStr = "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ="
cnStr = cnStr + PathStr
cnStr = cnStr + "; ReadOnly=False;Extended Properties= "Excel 8.0; HDR=YES;""
End Sub
Sub GetData(cloneRs As ADODB.Recordset, sheetName As String) 'シートデータを取得しRecordSetに変換
Dim SQLstr As String
Dim ColName As String
ColName = Sheets(sheetName).Range("A1").Value
SQLstr = "SELECT * FROM [" & sheetName & "$] WHERE " & ColName & " IS NOT
NULL"
Dim ShtConn As ADODB.Connection
Set ShtConn = New ADODB.Connection
ShtConn.ConnectionString = cnStr
ShtConn.Open
Dim dbRes As ADODB.Recordset
Set dbRes = New ADODB.Recordset
dbRes.Open SQLstr, ShtConn, adOpenKeyset, adLockOptimistic
If dbRes.RecordCount = 0 Then
GoTo Label1
End If
dbRes.MoveFirst
Dim fld As ADODB.Field
Set cloneRs = New ADODB.Recordset
For Each fld In dbRes.Fields
cloneRs.Fields.Append fld.Name, fld.Type, fld.DefinedSize, fld.Attributes
Next
cloneRs.Open
Do Until dbRes.EOF
cloneRs.AddNew
For Each fld In dbRes.Fields
cloneRs.Fields(fld.Name).Value = fld.Value
Next
cloneRs.Update
dbRes.MoveNext
Loop
Label1:
dbRes.Close
Set dbRes = Nothing
ShtConn.Close
End Sub
こうしておけば、RecordSetを宣言していろいろなRecordSetを取り出せます。
ではでは～☆ミ
