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