ExcelのVBAからAccessへ接続しデータを取得するコードのサンプル。接続方法はADOを利用する。接続する側にはAccessを入れる必要はないので管理者の端末にだけAccessがインストールされていればよい。
ExcelのVBAの参照設定の追加でVBE（VBAの編集画面）で、ツール→参照
ここで、Microsoft ActiveX Data Objects 2.X Library
または
Microsoft ActiveX Data Objects 6.1 Library
を選択しておく。
標準モジュールにコードをGetData関数、GetHaiban関数、ExecuteUpdInsDelSQL関数を作成しておけば、どこでも利用できるようになる。一か所でまとめておけば何かあった時にも対応しやすい。
コードの例）
Private Const DB_FILEPATH = "testdb.accdb"
'データ取得サンプル
Public Sub getdatasanm()
Dim str As String
Dim rs As ADODB.Recordset
str = " SELECT * FROM T_サンプル"
If GetData(str, rs) Then
Do Until rs.EOF
MsgBox (rs!名前)
rs.MoveNext
Loop
MsgBox (GetHaiban)
str = " UPDATE T_サンプル SET 住所 = '日本' "
ExecuteUpdInsDelSQL (str)
End If
End Sub
'----------------------------------------------------------------------------------------
'切断型データベースによるデータ取得
' 引数１：実行するSQL
' 引数２：検索結果を格納するRecordset（参照渡し）
'----------------------------------------------------------------------------------------
Public Function GetData(ByVal strSQL As String, ByRef rdSet As ADODB.Recordset) As Boolean
Dim myCon As New ADODB.Connection
Dim myRecordSet As New ADODB.Recordset
Dim strConnectionString As String
Dim rdReturn As ADODB.Recordset
On Error GoTo CatchError
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_FILEPATH
myCon.ConnectionString = strConnectionString
myCon.Open
myRecordSet.CursorLocation = adUseClient
'参照のみなので、読み取り専用（adLockReadOnly）で開く
'更新の場合は、レコード単位排他ロック（adLockPessimistic）を指定
myRecordSet.Open strSQL, myCon, adOpenDynamic, adLockReadOnly
'データの取得が終わったらすぐに接続を切る。この時点でmyRecordSetはAccessとは切り離されるので、自由に利用できる
'.NETのDataTableのイメージでよい
Set myRecordSet.ActiveConnection = Nothing
myCon.Close
Set myCon = Nothing
If myRecordSet.EOF Then
GetData = False
Exit Function
Else
GetData = True
'列数のカウント
Dim i As Long
Set rdReturn = New ADODB.Recordset
'戻り値のRecordSetを定義
' 切断型レコードセットを利用しているのでそのままSetすれば呼び出し元でも利用できると思われるが、
' 念のために別のレコードセットを定義。データ量によっては速度が遅く感じるかもしれないのでその際には修正検討。
For i = 0 To myRecordSet.Fields.Count - 1
rdReturn.Fields.Append myRecordSet.Fields(i).Name, myRecordSet.Fields(i).Type, myRecordSet.Fields(i).DefinedSize, adFldIsNullable
Next
rdReturn.Open
Do Until myRecordSet.EOF
With rdReturn
.AddNew
For i = 0 To myRecordSet.Fields.Count - 1
.Fields(i) = myRecordSet.Fields(i)
Next
.Update
End With
myRecordSet.MoveNext
Loop
End If
rdReturn.MoveFirst
Set rdSet = rdReturn
'参照渡しなので下記のようにCloseしてしまうと呼び出し元で利用できない
'rdReturn.Close
myRecordSet.Close
Set myRecordSet = Nothing
Exit Function
CatchError:
MsgBox "エラーが発生" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation
End Function
'----------------------------------------------------------------------------------------
'配番テーブルを利用
'----------------------------------------------------------------------------------------
Public Function GetHaiban() As Long
Dim myCon As New ADODB.Connection
Dim myRecordSet As New ADODB.Recordset
Dim strConnectionString As String
Dim strSQL As String
On Error GoTo CatchError
strSQL = " SELECT * FROM T_配番 WHERE ID = 1 "
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_FILEPATH
myCon.ConnectionString = strConnectionString
myCon.Open
myCon.BeginTrans
myRecordSet.Open strSQL, myCon, adOpenDynamic
GetHaiban = myRecordSet!配番No
Dim strUpdSQL As String
strUpdSQL = " UPDATE T_配番 SET 配番No = " & myRecordSet!配番No + 1 & " WHERE ID = 1 "
myCon.Execute strUpdSQL
myCon.CommitTrans
myRecordSet.Close
Set myRecordSet = Nothing
myCon.Close
Set myCon = Nothing
Exit Function
CatchError:
MsgBox "エラーが発生" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation
End Function
'----------------------------------------------------------------------------------------
'データ更新SQLを実行
' 引数１：実行するSQL（複数のSQLを同一トランザクションで実行したい場合は「;」で区切る
' 引数２：（オプション）複数のSQLを同一トランザクションで実行する場合は、Trueを指定
'----------------------------------------------------------------------------------------
Public Sub ExecuteUpdInsDelSQL(ByVal strSQL As String, Optional ByVal blnIsSomeSQL As Boolean = False)
Dim myCon As New ADODB.Connection
Dim myRecordSet As New ADODB.Recordset
Dim strConnectionString As String
On Error GoTo CatchError
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_FILEPATH
myCon.ConnectionString = strConnectionString
myCon.Open
myCon.BeginTrans
If blnIsSomeSQL Then
Dim sql() As String
sql = Split(strSQL, ";")
For i = 0 To UBound(sql)
If Trim(sql(i)) <> "" Then
myRecordSet.Open sql(i), myCon, adOpenDynamic, adLockPessimistic
End If
Next
Else
myRecordSet.Open strSQL, myCon, adOpenDynamic, adLockPessimistic
End If
myCon.CommitTrans
Set myRecordSet = Nothing
myCon.Close
Set myCon = Nothing
Exit Sub
CatchError:
MsgBox "エラーが発生" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub
Public Function NullSpace(ByVal obj) As Variant
If IsNull(obj) Then
NullSpace = ""
Else
NullSpace = obj
End If
End Function
Public Function NullZero(ByVal obj) As Variant
If IsNull(obj) Then
NullZero = 0
Else
NullZero = obj
End If
End Function
'データ取得サンプル
Public Sub getdatasanm()
Dim str As String
Dim rs As ADODB.Recordset
str = " SELECT * FROM T_サンプル"
If GetData(str, rs) Then
Do Until rs.EOF
MsgBox (rs!名前)
rs.MoveNext
Loop
MsgBox (GetHaiban)
str = " UPDATE T_サンプル SET 住所 = '日本' "
ExecuteUpdInsDelSQL (str)
End If
End Sub
'----------------------------------------------------------------------------------------
'切断型データベースによるデータ取得
' 引数１：実行するSQL
' 引数２：検索結果を格納するRecordset（参照渡し）
'----------------------------------------------------------------------------------------
Public Function GetData(ByVal strSQL As String, ByRef rdSet As ADODB.Recordset) As Boolean
Dim myCon As New ADODB.Connection
Dim myRecordSet As New ADODB.Recordset
Dim strConnectionString As String
Dim rdReturn As ADODB.Recordset
On Error GoTo CatchError
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_FILEPATH
myCon.ConnectionString = strConnectionString
myCon.Open
myRecordSet.CursorLocation = adUseClient
'参照のみなので、読み取り専用（adLockReadOnly）で開く
'更新の場合は、レコード単位排他ロック（adLockPessimistic）を指定
myRecordSet.Open strSQL, myCon, adOpenDynamic, adLockReadOnly
'データの取得が終わったらすぐに接続を切る。この時点でmyRecordSetはAccessとは切り離されるので、自由に利用できる
'.NETのDataTableのイメージでよい
Set myRecordSet.ActiveConnection = Nothing
myCon.Close
Set myCon = Nothing
If myRecordSet.EOF Then
GetData = False
Exit Function
Else
GetData = True
'列数のカウント
Dim i As Long
Set rdReturn = New ADODB.Recordset
'戻り値のRecordSetを定義
' 切断型レコードセットを利用しているのでそのままSetすれば呼び出し元でも利用できると思われるが、
' 念のために別のレコードセットを定義。データ量によっては速度が遅く感じるかもしれないのでその際には修正検討。
For i = 0 To myRecordSet.Fields.Count - 1
rdReturn.Fields.Append myRecordSet.Fields(i).Name, myRecordSet.Fields(i).Type, myRecordSet.Fields(i).DefinedSize, adFldIsNullable
Next
rdReturn.Open
Do Until myRecordSet.EOF
With rdReturn
.AddNew
For i = 0 To myRecordSet.Fields.Count - 1
.Fields(i) = myRecordSet.Fields(i)
Next
.Update
End With
myRecordSet.MoveNext
Loop
End If
rdReturn.MoveFirst
Set rdSet = rdReturn
'参照渡しなので下記のようにCloseしてしまうと呼び出し元で利用できない
'rdReturn.Close
myRecordSet.Close
Set myRecordSet = Nothing
Exit Function
CatchError:
MsgBox "エラーが発生" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation
End Function
'----------------------------------------------------------------------------------------
'配番テーブルを利用
'----------------------------------------------------------------------------------------
Public Function GetHaiban() As Long
Dim myCon As New ADODB.Connection
Dim myRecordSet As New ADODB.Recordset
Dim strConnectionString As String
Dim strSQL As String
On Error GoTo CatchError
strSQL = " SELECT * FROM T_配番 WHERE ID = 1 "
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_FILEPATH
myCon.ConnectionString = strConnectionString
myCon.Open
myCon.BeginTrans
myRecordSet.Open strSQL, myCon, adOpenDynamic
GetHaiban = myRecordSet!配番No
Dim strUpdSQL As String
strUpdSQL = " UPDATE T_配番 SET 配番No = " & myRecordSet!配番No + 1 & " WHERE ID = 1 "
myCon.Execute strUpdSQL
myCon.CommitTrans
myRecordSet.Close
Set myRecordSet = Nothing
myCon.Close
Set myCon = Nothing
Exit Function
CatchError:
MsgBox "エラーが発生" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation
End Function
'----------------------------------------------------------------------------------------
'データ更新SQLを実行
' 引数１：実行するSQL（複数のSQLを同一トランザクションで実行したい場合は「;」で区切る
' 引数２：（オプション）複数のSQLを同一トランザクションで実行する場合は、Trueを指定
'----------------------------------------------------------------------------------------
Public Sub ExecuteUpdInsDelSQL(ByVal strSQL As String, Optional ByVal blnIsSomeSQL As Boolean = False)
Dim myCon As New ADODB.Connection
Dim myRecordSet As New ADODB.Recordset
Dim strConnectionString As String
On Error GoTo CatchError
strConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_FILEPATH
myCon.ConnectionString = strConnectionString
myCon.Open
myCon.BeginTrans
If blnIsSomeSQL Then
Dim sql() As String
sql = Split(strSQL, ";")
For i = 0 To UBound(sql)
If Trim(sql(i)) <> "" Then
myRecordSet.Open sql(i), myCon, adOpenDynamic, adLockPessimistic
End If
Next
Else
myRecordSet.Open strSQL, myCon, adOpenDynamic, adLockPessimistic
End If
myCon.CommitTrans
Set myRecordSet = Nothing
myCon.Close
Set myCon = Nothing
Exit Sub
CatchError:
MsgBox "エラーが発生" & vbCrLf & Err.Number & vbCrLf & Err.Description, vbExclamation
End Sub
Public Function NullSpace(ByVal obj) As Variant
If IsNull(obj) Then
NullSpace = ""
Else
NullSpace = obj
End If
End Function
Public Function NullZero(ByVal obj) As Variant
If IsNull(obj) Then
NullZero = 0
Else
NullZero = obj
End If
End Function
