ExcelVBAでSQL

Option Explicit

Private Const adOpenDynamic As Long = 2
Private Const adLockOptimistic As Long = 3
Private Const adStateClosed As Long = 0

Sub ボタン1_Click()

Call DataGetSample

End Sub

'==========================================================
'コネクションを返す
'==========================================================
Public Function GetXLSConnection(DataSource As String) As Object

Dim objCN As Object
Dim strCNString As String


Set objCN = CreateObject("ADODB.Connection")


strCNString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & DataSource & ";" _
& "Extended Properties=""Excel 8.0;" _
& "HDR=Yes"";"

objCN.Open strCNString


Set GetXLSConnection = objCN

End Function

'==========================================================
'レコードセットを返す
'==========================================================
Public Function GetRecordSet(strSQL As String, objCN As Object) As Object

Dim objRS As Object


Set objRS = CreateObject("ADODB.Recordset")


objRS.Open strSQL, objCN, adOpenDynamic, adLockOptimistic


Set GetRecordSet = objRS


End Function

'==========================================================
'コネクション破棄
'==========================================================
Public Sub CloseConnection(objCN As Object)

If objCN.State <> adStateClosed Then

objCN.Close

End If


Set objCN = Nothing

End Sub

'==========================================================
'レコードセット破棄
'==========================================================
Public Sub CloseRecordSet(objRS As Object)

If objRS.State <> adStateClosed Then

objRS.Close

End If

Set objRS = Nothing


End Sub

'==========================================================
'データ取得サンプル
'==========================================================
Public Sub DataGetSample()

Dim objCN As Object
Dim objRS As Object
Dim strSQL As String
Dim lngF As Long


'コネクションを確立
Set objCN = GetXLSConnection(ThisWorkbook.FullName)


'抽出条件を作成
strSQL = "SELECT" '抽出フィールド(項目)を指定
strSQL = strSQL & " [header1]"
strSQL = strSQL & ", [header2]"
strSQL = strSQL & ", [header3]"
strSQL = strSQL & " FROM [Sheet1$]" 'データテーブルを指定
strSQL = strSQL & " WHERE 1 = 1" '抽出条件
'strSQL = strSQL & " AND [header2] >= 20"
strSQL = strSQL & " AND [header3] = '東海'"


'抽出実行
Set objRS = GetRecordSet(strSQL, objCN)


'抽出結果を出力
With wsXLSDataBase

With .Range("rngXDB_DataTop")

'出力エリアにある既存データを消去
.CurrentRegion.ClearContents

'フィールド(項目)名を出力
For lngF = 0 To objRS.Fields.Count - 1

.Offset(, lngF).Value = objRS.Fields(lngF).Name

Next lngF

'データを出力
.Offset(1).CopyFromRecordset objRS

End With

End With


END_PROC:

'レコードセットを閉じる
Call CloseRecordSet(objRS)

'コネクションを閉じる
Call CloseConnection(objCN)

End Sub