VBA/DB（Access）よりエクセルに抽出
参照（Access）：https://ateitexe.com/access-database1//
参照（Access設定時の参考）：http://www.serpress.co.jp/access/vba018.html
参照（Excel)：http://www.sanryu.net/acc/tips/tips252.htm
参照（Excel出力）：http://d.hatena.ne.jp/ogohnohito/20111123/p1
参照（PASS）：https://kozy-twt.hatenadiary.org/entry/20101013/1286958157
参照（パラメーター）：https://selifelog.com/blog-entry-159.html
実験対象バージョン：Excel2007、Access2007
参照（Access設定時の参考）：http://www.serpress.co.jp/access/vba018.html
参照（Excel)：http://www.sanryu.net/acc/tips/tips252.htm
参照（Excel出力）：http://d.hatena.ne.jp/ogohnohito/20111123/p1
参照（PASS）：https://kozy-twt.hatenadiary.org/entry/20101013/1286958157
参照（パラメーター）：https://selifelog.com/blog-entry-159.html
実験対象バージョン：Excel2007、Access2007
サンプル
Excel(VBA）よりAcessファイルを選び、データを抽出し、Sheetに貼り付けるものです。
Accessには、パスワード無と有で少し違います。
Accessには、パスワード無と有で少し違います。
Accessパスワード無
DB_Access_Exc
※メニューバーの[ツール(T)]→[参照設定(R)...]→「Microsoft ActiveX Data Objects ×× Library」にチェックを入れて[OK]が必要です。
'*******************************************************
' クエリ実行後、エクセル書き出し
'
' sSQL ： SQL文
' sDBname ： DB名
' iGyo ： Excel書き始め行数
' iRetu ： Excel書き始め列数
'*******************************************************
Sub DB_Access_Exc(sSQL As String, sDBname As String, iGyo As Integer, iRetu As Integer)
'-----------------
' エクセル用
'-----------------
Dim xlsApp As Variant
Dim xlsWorkbook As Variant
Dim xlsSheet As Variant
Dim vExcelName As Variant
'-------------
' DB用
'-------------
Dim adoReco As ADODB.Recordset
Dim adoCn As New ADODB.Connection
Dim cmd As ADODB.Command
'================
' 初期化
'================
'DB設定--------------------------------------
'ADOコネクションオブジェクトを作成
Set adoCn = CreateObject("ADODB.Connection")
'ADOレコードセットオブジェクトを作成
Set adoReco = CreateObject("ADODB.Recordset")
'Access2007以降
adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
'データベースの場所
adoCn.ConnectionString = "Data Source=" & sDBname
adoCn.Open
Set cmd = New ADODB.Command
'データセット
With cmd
.ActiveConnection = adoCn
.CommandText = sSQL
.Parameters.Refresh
End With
'エクセル設定-------------------------------
'インスタンスの生成
Set xlsApp = CreateObject("excel.application")
'ブックを新規で開く
Set xlsWorkbook = xlsApp.Workbooks.Add
'シートを変数に設定
Set xlsSheet = xlsWorkbook.Worksheets(1)
'=====================================================
' レコード読み込み
'=====================================================
adoReco.Open cmd, , adOpenKeyset, adLockOptimistic
'=======================================================
' レコードセットの内容をワークシートに出力
'=======================================================
xlsSheet.Cells(iGyo, iRetu).CopyFromRecordset adoReco
'EXCELを表示
xlsApp.Visible = True
'保存場所を指定
vExcelName = xlsApp.Application.GetSaveAsFilename(Title:="DB抽出完了", InitialFileName:="×××.xlsx", FileFilter:="Excel ブック (*.xlsx), *.xlsx")
'保存
If vExcelName <> False Then
xlsWorkbook.SaveAs FileName:=vExcelName, FileFormat:=xlOpenXMLWorkbook
End If
'ブックを閉じる
xlsWorkbook.Close
'初期化
adoReco.Close
adoCn.Close
Set adoReco = Nothing
Set xlsSheet = Nothing
Set xlsWorkbook = Nothing
Set xlsApp = Nothing
End Sub
呼び出す用
sSQL：sql文を記載して下さい。１：Excel開始行、開始列の順番で記載して下さい。
Accessは、2003のｍｄｂでも確認しています。
Sub Main_Kaiseki()
Dim sSQL As String 'SQL文
Dim sDBname As String 'DBファイル名
Dim sBook As String '新規ブックのファイル名
'=====================
' ファイル指定
'=====================
With Application.FileDialog(msoFileDialogOpen)
.Title = "ファイルの選択"
'ファイルの種類を設定
.Filters.Clear
.Filters.Add "Microsoft Access (*.mdb,*.accdb)", "*.mdb,*.accdb"
'複数ファイル選択を許可しない
.AllowMultiSelect = False
'ダイアログを表示
If .Show = -1 Then
'ファイルが選択されたとき
'そのフルバスを返り値に設定
sDBname = Trim(.SelectedItems.Item(1))
Else
'ファイルが選択されなければ長さゼロの文字列を返す
sDBname = ""
End If
End With
'SQL文
sSQL = "select * from aa"
'エクセル貼り付け
Call DB_Access_Exc(sSQL, sDBname, 1, 1)
End Sub
VBA/DB（Access）よりエクセルに抽出 in PASS編
DB_Access_Exc_Pass
Accessにパスワードがある場合
'*******************************************************
' クエリ実行後、エクセル書き出し
'
' sSQL ： SQL文
' sDBname ： DB名
' sDBPass ： DBパスワード
' iGyo ： Excel書き始め行数
' iRetu ： Excel書き始め列数
'*******************************************************
Sub DB_Access_Exc_Pass(sSQL As String, sDBname As String, sDBPass As String, iGyo As Integer, iRetu As Integer)
'-----------------
' エクセル用
'-----------------
Dim xlsApp As Variant
Dim xlsWorkbook As Variant
Dim xlsSheet As Variant
Dim vExcelName As Variant
'-------------
' DB用
'-------------
Dim adoReco As ADODB.Recordset
Dim adoCn As New ADODB.Connection
Dim cmd As ADODB.Command
'================
' 初期化
'================
'DB設定--------------------------------------
'ADOコネクションオブジェクトを作成
Set adoCn = CreateObject("ADODB.Connection")
'ADOレコードセットオブジェクトを作成
Set adoReco = CreateObject("ADODB.Recordset")
'Access2007以降
adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
'データベースの場所
adoCn.ConnectionString = "Data Source=" & sDBname
& ";Jet OLEDB:Database Password=" _
& sDBPass
adoCn.Open
Set cmd = New ADODB.Command
'データセット
With cmd
.ActiveConnection = adoCn
.CommandText = sSQL
.Parameters.Refresh
End With
'エクセル設定-------------------------------
'インスタンスの生成
Set xlsApp = CreateObject("excel.application")
'ブックを新規で開く
Set xlsWorkbook = xlsApp.Workbooks.Add
'シートを変数に設定
Set xlsSheet = xlsWorkbook.Worksheets(1)
'=====================================================
' レコード読み込み
'=====================================================
adoReco.Open cmd, , adOpenKeyset, adLockOptimistic
'=======================================================
' レコードセットの内容をワークシートに出力
'=======================================================
xlsSheet.Cells(iGyo, iRetu).CopyFromRecordset adoReco
'EXCELを表示
xlsApp.Visible = True
'保存場所を指定
vExcelName = xlsApp.Application.GetSaveAsFilename(Title:="DB抽出完了", InitialFileName:="×××.xlsx", FileFilter:="Excel ブック (*.xlsx), *.xlsx")
'保存
If vExcelName <> False Then
xlsWorkbook.SaveAs FileName:=vExcelName, FileFormat:=xlOpenXMLWorkbook
End If
'ブックを閉じる
xlsWorkbook.Close
'初期化
adoReco.Close
adoCn.Close
Set adoReco = Nothing
Set xlsSheet = Nothing
Set xlsWorkbook = Nothing
Set xlsApp = Nothing
End Sub
そのため、37～39行目の引数にsDBPassが増えます。
呼び出す用
最初の呼び出し用を上記に変えて下さい。
Sub Main_Kaiseki()
Dim sSQL As String 'SQL文
Dim sDBname As String 'DBファイル名
Dim sBook As String '新規ブックのファイル名
'=====================
' ファイル指定
'=====================
With Application.FileDialog(msoFileDialogOpen)
.Title = "ファイルの選択"
'ファイルの種類を設定
.Filters.Clear
.Filters.Add "Microsoft Access (*.mdb,*.accdb)", "*.mdb,*.accdb"
'複数ファイル選択を許可しない
.AllowMultiSelect = False
'ダイアログを表示
If .Show = -1 Then
'ファイルが選択されたとき
'そのフルバスを返り値に設定
sDBname = Trim(.SelectedItems.Item(1))
Else
'ファイルが選択されなければ長さゼロの文字列を返す
sDBname = ""
End If
End With
'SQL文
sSQL = "select * from aa"
'エクセル貼り付け
Call DB_Access_Exc_Pass(sSQL, sDBname,sDBPass, 1, 1)
End Sub
VBA/DB（Access）よりエクセルに抽出 in パラメータ編
DB_Access_Exc_Para
パラメータ数に応じて「.Parameters(×)」を増やして下さい。そのため、引数にsPara×が増えます。
'*******************************************************
' クエリ実行後、エクセル書き出し
'
' sSQL ： SQL文
' sDBname ： DB名
' sPara1 ： パラメータ１
' sPara2 ： パラメータ２
' iGyo ： Excel書き始め行数
' iRetu ： Excel書き始め列数
'*******************************************************
Sub DB_Access_Exc_Para(sSQL As String, sDBname As String, sPara1 As String, sPara2 As String, iGyo As Integer, iRetu As Integer)
'-----------------
' エクセル用
'-----------------
Dim xlsApp As Variant
Dim xlsWorkbook As Variant
Dim xlsSheet As Variant
Dim vExcelName As Variant
'-------------
' DB用
'-------------
Dim adoReco As ADODB.Recordset
Dim adoCn As New ADODB.Connection
Dim cmd As ADODB.Command
'================
' 初期化
'================
'DB設定--------------------------------------
'ADOコネクションオブジェクトを作成
Set adoCn = CreateObject("ADODB.Connection")
'ADOレコードセットオブジェクトを作成
Set adoReco = CreateObject("ADODB.Recordset")
'Access2007以降
adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
'データベースの場所
adoCn.ConnectionString = "Data Source=" & sDBname
adoCn.Open
Set cmd = New ADODB.Command
'データセット
With cmd
.ActiveConnection = adoCn
.CommandText = sSQL
.Parameters.Refresh
.Parameters(0) = sPara1
.Parameters(1) = sPara2
End With
'エクセル設定-------------------------------
'インスタンスの生成
Set xlsApp = CreateObject("excel.application")
'ブックを新規で開く
Set xlsWorkbook = xlsApp.Workbooks.Add
'シートを変数に設定
Set xlsSheet = xlsWorkbook.Worksheets(1)
'=====================================================
' レコード読み込み
'=====================================================
adoReco.Open cmd, , adOpenKeyset, adLockOptimistic
'=======================================================
' レコードセットの内容をワークシートに出力
'=======================================================
xlsSheet.Cells(iGyo, iRetu).CopyFromRecordset adoReco
'EXCELを表示
xlsApp.Visible = True
'保存場所を指定
vExcelName = xlsApp.Application.GetSaveAsFilename(Title:="DB抽出完了", InitialFileName:="×××.xlsx", FileFilter:="Excel ブック (*.xlsx), *.xlsx")
'保存
If vExcelName <> False Then
xlsWorkbook.SaveAs FileName:=vExcelName, FileFormat:=xlOpenXMLWorkbook
End If
'ブックを閉じる
xlsWorkbook.Close
'初期化
adoReco.Close
adoCn.Close
Set adoReco = Nothing
Set xlsSheet = Nothing
Set xlsWorkbook = Nothing
Set xlsApp = Nothing
End Sub
呼び出す用
引数にsPara×が増えます。
Sub Main_Kaiseki()
Dim sSQL As String 'SQL文
Dim sDBname As String 'DBファイル名
Dim sBook As String '新規ブックのファイル名
'=====================
' ファイル指定
'=====================
With Application.FileDialog(msoFileDialogOpen)
.Title = "ファイルの選択"
'ファイルの種類を設定
.Filters.Clear
.Filters.Add "Microsoft Access (*.mdb,*.accdb)", "*.mdb,*.accdb"
'複数ファイル選択を許可しない
.AllowMultiSelect = False
'ダイアログを表示
If .Show = -1 Then
'ファイルが選択されたとき
'そのフルバスを返り値に設定
sDBname = Trim(.SelectedItems.Item(1))
Else
'ファイルが選択されなければ長さゼロの文字列を返す
sDBname = ""
End If
End With
'SQL文
sSQL = "select * from aa"
'エクセル貼り付け
DB_Access_Exc_Para(sSQL, sDBname,sPara1,ｓPara2, 1, 1)
End Sub