2018年3月10日土曜日

EXCEL VBA で、RecordSet を使いまわしする

みなさん、こんにちは。


今回も先日に続き 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を取り出せます。


ではでは~☆ミ

2 件のコメント:

  1. 突然の投稿失礼します。
    私は、生業としてVBプログラマをしておるんですが
    つい最近、エクセルのシートデータがレコードセットに
    取りこめることを知り、目からうろこで開発をしております。
    そこで使用していて疑問が出てしまっていろいろなサイトを
    探し回ってこのサイトにたどり着いた次第です。
    質問というのは、エクセルのシートをレコードセットに
    取り込んだ際に、ある特定のセルから先の情報がレコードセットに
    取り込むことができないということです。
    取り込み先のシートは、A列からDW列まで127列シートで
    それを、シートとコネクトして取り込む方法で行っています。
    ですが、取り込んだ後ウォッチで中身を見るとItem(10)以降が
    全てNull値になってしまって値が取り込めないのです。
    原因がわからず悩んでしまって、どうにかならないかと思って
    不躾ではと思いましたが投稿させていただきました。
    お教授いただけると幸いです。

    返信削除
    返信
    1. Unknownさん、こんにちは。

      既に半年以上経過されているので解決済ではないかと思いますが・・・・・。

      セルの書式が変になっていませんか?
      値のクリアではなく列自体を削除してみて、データをテキストで貼り付けてみて動作を検証してみては如何でしょうか。

      また、127列のフィールド数とのことですので、何かの仕様制限に引っかかっているかも知れません。
      20列くらいの仮データを作って、徐々に列数を増やしてみて動作をみてみるのは如何でしょうか。

      今思いつくのはそんなところです。

      ではでは~☆ミ

      削除