ExcelVBAとAccessの連携 番外 リファクタリングしたコード

ExcelVBAとAccessの連携 番外 リファクタリングしたコード

このブログを開設した当初からあるこのシリーズ。書籍にもしていただいて、さらに改訂版ももうすぐ出るということで、あれからかなり綺麗なコードが書けるようになったと思います。過去のコードの供養のためにも、リファクタリングしたものを書き残しておきます。


関連記事

この連載がもっと実用的なサンプルで書籍になりました！

はじめに

本記事で紹介するコードは、自著「Excel & Access連携 実践ガイド（改訂版）」で書かれているものの一部です。この連載記事→書籍初版→書籍改訂版を経てリファクタリングを重ねた、ExcelとAccessの連携部分のみを抜粋しています。コードだけ見ればわかる方にはこれだけでお使いいただけます。

書籍のほうは、VBAの基礎から詳細なコードの解説、Excelユーザーフォームを介したAccessとの連携などもみっちり書かれておりますので、興味があればぜひそちらもよろしくお願いいたします！

Accessとやりとりする専用の標準モジュールを作成

DBに接続したり処理したりする部分の実働部分を記載するモジュールを作ります。新規標準モジュールで、オブジェクト名をAccessExchangeとします（名前は任意です）。

対象となるAccessの接続/接続解除のためのコードを書きます。

'# AccessExchange
Option Explicit
Private m_cn As Object 'ADOコネクション用オブジェクトの宣言
Private Const adStateOpen = 1 'レコードセットが開いている場合の設定値
Private Const adOpenKeyset = 1 'レコードセットカーソルタイプの設定値
  
Private Sub connectDB()
  '## 接続
  
  Set m_cn = CreateObject("ADODB.Connection") 'ADOコネクションを作成
  m_cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=C:\data.accdb;" 'Accessファイルを指定してコネクションを開く
End Sub

Private Sub disconnectDB()
  '## 接続解除
  
  If Not m_cn Is Nothing Then
    m_cn.Close
    Set m_cn = Nothing
  End If
End Sub

ADOコネクション用の変数はモジュールレベルのためm_をつけています。

INSERT, UPDATE, DELETE

さきほど作ったAccessExchangeに以下を追記します。レコードの挿入・更新・削除を行うプロシージャです。トランザクションもついています。

Public Function tryExecute(ByVal sqlList As Collection) As Boolean
  '## SQLの実行
  
  On Error GoTo ErrorHandler 'エラーが起きたら「ErrorHandler」にジャンプする指示
  
  Call connectDB '接続
  
  m_cn.BeginTrans 'トランザクション開始
   
  '実行
  Dim sql As Variant
  For Each sql In sqlList 'SQL文リストをループ
    m_cn.Execute sql '1行ずつ実行
  Next sql
  
  m_cn.CommitTrans '確定
  
  tryExecute = True '成功だった場合、関数の結果にTrueを入れる
  GoTo Finally '正常に終了したら最終処理へジャンプ
  
ErrorHandler: '例外処理
  m_cn.RollbackTrans '元の状態へ戻す
  Dim msgTxt As String
  msgTxt = "Error #: " & Err.Number & vbNewLine & vbNewLine & Err.Description 'エラーメッセージが入る
  MsgBox msgTxt, vbOKOnly + vbCritical, "エラー" 'メッセージ出力
  
Finally: '最終処理
  Call disconnectDB '接続解除
End Function

コレクション形式のSQL文を引数にして上記のプロシージャを呼び出せば実行できます。

上記を利用するプロシージャの例として、任意のモジュールに以下のように書きます。SQLはFor文などを使って複数処理できるようにコレクション型にしています。

Sub ExecuteSQL()
  '## SQLの実行
   
  'SQL文作成
  Dim sql As String
  sql = "任意のINSERT/UPDATE/DELETE文"
  
  'コレクションの作成
  Dim sqlList As Collection
  Set sqlList = New Collection
  sqlList.Add sql 'コレクションへ追加
          
  '実行
  If tryExecute(sqlList) Then '処理が成功した場合
    MsgBox "正常に追加されました", vbOKCancel + vbInformation, "終了" '終了メッセージ
  End If
End Sub

失敗した場合はエラーメッセージが、成功した場合は終了メッセージが出力されます。

SELECT（任意のシートに展開）

AccessExchangeに以下を追記します。レコードの抽出を行うプロシージャです。SQLのほかにワークシートとセルを引数に渡すことで、抽出結果を任意の場所に展開します。

Public Sub putRsOnSheet(ByVal sql As String, ByVal ws As Worksheet, ByVal rng As Range)
  '## レコードセットをシートへ展開
  
  On Error GoTo Err_Handler 'エラーが起きたら「ErrorHandler」にジャンプする指示
  
  Call connectDB '接続
          
  'レコードセットのオープン
  Dim rs As Object 'レコードセット用変数宣言
  Set rs = CreateObject("ADODB.RecordSet") 'ADOレコードセットオブジェクトを作成
  rs.Open sql, m_cn 'レコードセットを開く
  
  '空だったら最終処理へ
  If rs Is Nothing Or (rs.BOF And rs.EOF) Then 'レコードセットやレコードが存在しなかった場合
    MsgBox "対象レコードがありません", vbInformation, "確認" 'メッセージ出力
    GoTo Finally '最終処理へジャンプ
  End If
  
  'シートに展開
  Dim tgtRow As Long
  tgtRow = rng.Row  'スタートの行
  Dim tgtCol As Long
  tgtCol = rng.Column  'スタートの列
  Application.ScreenUpdating = False '画面更新OFF
  Do Until rs.EOF 'レコードセットが終了するまで処理を繰り返す
    Dim fldNum As Long 'フィールドの繰り返し用変数
    For fldNum = 0 To rs.Fields.Count - 1 'フィールドの数だけ繰り返す
      ws.Cells(tgtRow, tgtCol + fldNum).Value = rs(fldNum) 'フィールドの並び順でセルに書き込む
    Next fldNum '次のフィールドへ
    tgtRow = tgtRow + 1 '行をカウントアップする
    rs.MoveNext '次のレコードに移動する
  Loop
  Application.ScreenUpdating = True '画面更新ON
  
  GoTo Finally '正常に終了したら最終処理へジャンプ
  
Err_Handler: '例外処理
  Dim msgTxt As String
  msgTxt = "Error #: " & Err.Number & vbNewLine & vbNewLine & Err.Description 'エラーメッセージが入る
  MsgBox msgTxt, vbOKOnly + vbCritical, "エラー" 'メッセージ出力

Finally: '最終処理
  If Not rs Is Nothing Then 'レコードセットオブジェクトが存在している場合のみ
    If rs.State = adStateOpen Then rs.Close 'レコードセットが開いていたら閉じる
    Set rs = Nothing
  End If
  
  Call disconnectDB '接続解除
End Sub

上記を利用するプロシージャの例として、任意のモジュールに以下のように書きます。

Sub loadRecord()
  '## レコードをシートへ
  
  '対象シートを設定
  Dim ws As Worksheet
  Set ws = XXX
  
  'SQL文の作成
  Dim sql As String
  sql = "任意のSELECT文"

  'レコードセットをシートへ展開
  Call putRsOnSheet(sql, ws, ws.Range("A1"))
End Sub

SELECTで抽出したレコードを、任意シート上の任意セルを起点（左上）として展開します。繰り返す場合は対象シート範囲をクリアするコードも加えてください。

SELECT（二次元配列に入れて受け取る）

AccessExchangeに以下を追記します。サブルーチンではなく関数で、抽出したレコードセットを二次元配列に入れて受け取ります。シートに出力せずに内部処理したい場合に使えます。

Public Function getRsInArray(ByVal sql As String) As Variant
  '## レコードセットを配列へ入れて返す
  
  On Error GoTo Err_Handler 'エラーが起きたら「ErrorHandler」にジャンプする指示
  
  Call connectDB '接続
          
  'レコードセットのオープン
  Dim rs As Object 'レコードセット用変数宣言
  Set rs = CreateObject("ADODB.RecordSet") 'ADOレコードセットオブジェクトを作成
  rs.Open sql, m_cn, adOpenKeyset 'カーソルタイプを指定してレコードセットを開く
  
  '空だったら最終処理へ
  If rs Is Nothing Or (rs.BOF And rs.EOF) Then 'レコードセットやレコードが存在しなかった場合
    getRsInArray = Array() '空の配列を返す
    GoTo Finally '最終処理へジャンプ
  End If
  
  '配列に展開
  Dim ary() As Variant
  ReDim ary(rs.RecordCount - 1, rs.Fields.Count - 1) '配列の要素数を定義
  Dim rsNum As Long '縦要素（レコードセット）の繰り返し用変数
  Dim fldNum As Long '横要素（フィールド）の繰り返し用変数
  Do Until rs.EOF 'レコードセットが終了するまで処理を繰り返す
    For fldNum = 0 To rs.Fields.Count - 1 'フィールドの数だけ繰り返す
      ary(rsNum, fldNum) = rs(fldNum) '配列に格納
    Next fldNum
    rsNum = rsNum + 1 '縦要素をカウントアップする
    rs.MoveNext '次のレコードに移動する
  Loop
  
  getRsInArray = ary '配列を返す
  
  GoTo Finally '正常に終了したら最終処理へジャンプ
  
Err_Handler: '例外処理
  Dim msgTxt As String
  msgTxt = "Error #: " & Err.Number & vbNewLine & vbNewLine & Err.Description 'エラーメッセージが入る
  MsgBox msgTxt, vbOKOnly + vbCritical, "エラー" 'メッセージ出力
  getRsInArray = Array() '空の配列を返す

Finally: '最終処理
  If Not rs Is Nothing Then 'レコードセットオブジェクトが存在している場合のみ
    If rs.State = adStateOpen Then rs.Close 'レコードセットが開いていたら閉じる
    Set rs = Nothing
  End If
  
  Call disconnectDB '接続解除
End Function

上記を利用するプロシージャの例として、任意のモジュールに以下のように書きます。

Sub loadRecord()
  '## レコードを配列へ
    
  'SQL作成
  Dim sql As String
  sql = "任意のSELECT文"
  
  'レコードセットを配列で取得
  Dim ary() As Variant
  ary = getRsInArray(sql)
  
  If isEmptyArray(ary) Then Exit Sub '空の配列だったら終了
  
  '中身の確認
  Dim rsCount As Long: rsCount = UBound(ary, 1) '第1要素（レコード）数
  Dim fldCount As Long: fldCount = UBound(ary, 2) '第2要素（フィールド）数
  Dim x As Long, y As Long
  For x = 0 To rsCount
    For y = 0 To fldCount
      Debug.Print ary(x, y); 'フィールドを改行せずイミディエイトウィンドウに出力
    Next y
    Debug.Print "" 'レコード切り替えでイミディエイトウィンドウを改行
  Next x
End Sub

VBAの配列は空判定がちょっと面倒なので、以下のような自作関数を任意のモジュールに書くとスマートじゃないかなと思います。上の12行目で使っています。

Public Function isEmptyArray(ByVal tgtAry As Variant) As Boolean
  '## 配列が空か判定
  
  On Error GoTo Err_Handler 'エラーが起きたら「ErrorHandler」にジャンプする指示
  If UBound(tgtAry) >= 0 Then '配列に要素が存在したら
    Exit Function '終了（Falseを返す）
  End If
  
Err_Handler: 'エラーもしくは要素が存在しない場合
  isEmptyArray = True 'Trueを返す
End Function

これで、レコードセットを配列で取得して、その配列を表の形でイミディエイトウィンドウに出力できると思うので、あとはお好きな処理になるように手を加えればOK。

以上です。初期のころより短くて汎用性の高いコードになってると思います！

公開日：2017/05/01
更新日：2021/04/07

ExcelVBAに興味をお持ちの方は、こちらの記事もどうぞ！

書籍を執筆しています。

Google+
  はてブ
1 Pocket
6 feedly
15

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

このサイトはスパムを低減するために Akismet を使っています。コメントデータの処理方法の詳細はこちらをご覧ください。

コメントは承認制ですので、反映までしばらくお待ち下さい。（稀にスパムの誤判定にて届かないこともあるようですので、必要な際はお問い合わせからお願い致します。）