ExcelVBAおぼえがきFunction 2
今回は主にDB関係かなー。
色々VBAで社内ツールを作ってはいるけどあんまり公開するほど汎用性の高い関数はできないね。
クエリ発行
accessファイルにクエリ発行する。取得したデータは指定したセルを起点としてベタっと貼り付け。
コレを標準モジュールに入れておけば安泰。
Option Explicit '変数 'office2007用 Private Const strProvider = "Provider=Microsoft.ACE.OLEDB.12.0;" 'DBファイルパス Private strDbPath As String '関数 'DBファイルパス設定 Public Sub SetDbPath(ByVal buf As String) strDbPath = "Data Source=" & buf & ";" End Sub 'クエリ発行 '登録, 更新 Public Sub QueryExecute(ByVal strSQL As String) Dim connect As New ADODB.Connection 'エラー制御ON(DEBUG用) On Error GoTo SQLERROR 'DB接続 connect.Open strProvider & strDbPath 'クエリ発行 Call connect.Execute(strSQL) 'エラー制御OFF(DEBUG用) On Error GoTo 0 'terminate connect.Close Set connect = Nothing Exit Sub SQLERROR: Call ErrorInfo(connect, strSQL) End Sub '検索 Public Sub QuerySelect(ByVal strSQL As String, ByVal rngTarget As Range) Dim connect As New ADODB.Connection Dim recordset As New ADODB.recordset 'エラー制御ON(DEBUG用) On Error GoTo SQLERROR 'DB接続 connect.Open strProvider & strDbPath 'クエリ発行 recordset.Open strSQL, connect, adLockReadOnly 'データ格納 rngTarget.CopyFromRecordset recordset 'エラー制御OFF(DEBUG用) On Error GoTo 0 'terminate recordset.Close Set recordset = Nothing connect.Close Set connect = Nothing Exit Sub SQLERROR: Call ErrorInfo(connect, strSQL) End Sub 'エラー詳細の表示 Private Sub ErrorInfo(ByVal connect As ADODB.Connection, ByVal strSQL As String) Debug.Print "=== ERROR ===" 'イミディエイトウィンドウへエラー詳細を出力 With connect.Errors.Item(0) Debug.Print " Description=" & .Description Debug.Print " HelpContext=" & .HelpContext Debug.Print " HelpFile=" & .HelpFile Debug.Print " NativeError=" & .NativeError Debug.Print " Number=" & .Number Debug.Print " Source=" & .Source Debug.Print " SQLState=" & .SqlState End With Debug.Print " SQL=" & strSQL Debug.Print "=== ERROR ===" End Sub
SQL文作成
WHERE句を複数つけたり付けなかったりする。
入力した検索条件が複数ならif文内をまるごとコピーするのが手っ取り早いかしら。loopで回してもいいと思うー。
取得したデータの貼り付け先などは適宜変更してください。
Private Sub SelectData(ByVal TblName As String) Dim strSQL As String Dim ret As Integer strSQL = "SELECT * FROM " & TblName & " " '検索条件 If 入力した検索条件 <> "" Then ret = InStr(1, strSQL, "WHERE", vbBinaryCompare) '絞り込み strSQL = strSQL & IIf(ret <> 0, IIf(IsNull(ret) = False, "AND ", "WHERE "), "WHERE ") strSQL = strSQL & "○○ = '" & 入力した検索条件 & "' " End If strSQL = strSQL & ";" 'Debug.Print strSQL 'クエリ発行 Call QuerySelect(strSQL, Range("A1")) End Sub