[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エクセルとアクセスを活用していたのですが、アクセスが廃止になりました』（あや）
エクセルVBA アクセスクエリ アクセスVBA を使って、集計をしております
今回、アクセスが廃止されることになり 対応方法を考えています （出来る限り現状は変えず回避方向で…）
集計作業の内容 エクセルのデータファイルを、 １エクセル側からアクセスのインポートファンクションを呼び出し ２アクセスVBAでインポート ３アクセスクエリで結合や抽出条件を指定し 必要なデータに成形 ４エクセル側からアクセスのエクスポートファンクションを呼び出し ５アクセスVBAでエクセルに出力
（実際の記述） １エクセル側からアクセスのインポートファンクションを呼び出し
’エクセル モジュールに記述
'Accessにインポート＆★チェック.xlsにエクスポート
strAccessPath = ThisWorkbook.Path & "\チェック.mdb"
Set objAccess = CreateObject("Access.Application")
objAccess.Opencurrentdatabase strAccessPath
objAccess.Run "Fnインポート"
objAccess.Run "Fnエクスポート" ☆
objAccess.closecurrentdatabase
objAccess.Quit
Set objAccess = Nothing
２アクセスVBAでインポート
’アクセスモジュールに記述 Function Fnインポート() On Error GoTo エラー
Dim Active_mdb As String
Dim varac As Variant
Dim varxls As Variant
Active_mdb = CurrentProject.Path
varac = "tbl_チェック"
varxls = Active_mdb & "\チェック.xls"
DoCmd.DeleteObject acTable, varac
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel9, _
varac, varxls, True, "チェック!"
Exit Function
エラー:
MsgBox "予期せぬエラーが発生しました。" & Chr(13) & _
"エラー番号：" & Err.Number & Chr(13) & _
"エラー内容：" & Err.Description, vbCritical
End Function
３アクセスクエリで結合や抽出条件を指定し 必要なデータに成形 クエリデザインビューでテーブル結合や抽出条件を指定
４エクセル側からアクセスのエクスポートファンクションを呼び出し （１エクセル側からアクセスのインポートファンクションを呼び出し）の☆部分
５アクセスVBAでエクスポート
Function Fnエクスポート()
On Error GoTo エラー
Dim Active_mdb As String Dim varac As Variant Dim varxls As Variant
Active_mdb = CurrentProject.Path
varxls = Active_mdb & "\★チェック.xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, _
"qry_作業1", varxls, True
Exit Function
エラー:
MsgBox "予期せぬエラーが発生しました。" & Chr(13) & _
"エラー番号：" & Err.Number & Chr(13) & _
"エラー内容：" & Err.Description, vbCritical
End Function
（伝わりにくい部分がいくつかあるかと思います…） こんな形でアクセスを使用しているのですが アクセスがなくなることにより、 アクセスのクエリを活用している部分を他の動きで代用する必要があり
クエリを代用するものでわたしが思いつくのは エクセルのVLOOKUPをマクロで再現したり、かなと思いますが たくさんのクエリを使っているため、 良い方法はないかなと考えております
アクセスがなくても、エクセルからデータベースを動かすなど…？ 幅広く教えていただけると勉強になります
*説明不足があるかと思いますので、 そのときはご指示下さい
＜ 使用 Excel：Excel2010、使用 OS：WindowsXP ＞
しかし、移植にはこれらが仇になってしまうので、新たに標準のSQL文やVBAの処理で作り直すしかないかと思います。
クエリの性能に依存した処理をしているほど、移植は大変になるでしょう。
（移植より、新たな処理を考えたほうが早いかもしれませんね）
VBAでは、ADODB.Connection 等を使用して、MDBだけでなく、シートやCSVをDB扱いすることもできます。
Accessに慣れているのでしたら、集計が必要な場合に、SQL文で処理する方法もありますので、調べてみてください。
（Excel2010のようなので、.Provider = "Microsoft.ACE.OLEDB.12.0" なんかも検索候補に）
（???） 2014/09/03(水) 16:26
>アクセスがなくても、エクセルからデータベースを動かす
あやさんの投稿から、ファイルは、Office2003以前のバージョンで管理されていたものを Excel2010でアクセスなしで管理する ということでしょうか？
よって、同じ仕様をアクセスアプリを使った場合と対比できるようにサンプル仕様を明確にしたいと思います。
仕様は、Excelファイルとmdbファイルでデータのやり取りを行い、結果を新たなExcelファイルに作成する という内容です。
ファイル構成
sample1.xls ----＞ sample2.xls
dbsamp.mdb
VBAsamp.xls ---- VBAコードがあるExcelファイル（サンプルデータ作成コードと仕様実行コード）
sample1.xls Sheet1に以下のようなデータを用意します。
Ａ Ｂ Ｃ Ｄ 1 会員番号 氏名 出身 血液型 2 1 奥田 美香 東京都 Ａ型 3 2 榎田 道子 東京都 ＡＢ型 4 3 吉野 佳代子 埼玉県 Ｏ型 5 4 新田 恵利 埼玉県 Ｏ型 6 5 中島 美春 東京都 Ａ型 7 6 樹原亜紀 神奈川県 ＡＢ型 8 7 友田 麻美子 東京都 Ａ型
Dbsamp.mdb
tbl1 というテーブルとqry1というクエリを用意します。
tbl1 は、以下のようなデータを用意します。
会員番号 備考 1 週間文春タバコフォーカス事件にて脱退 2 週間文春タバコフォーカス事件にて脱退 3 週間文春タバコフォーカス事件にて脱退 4 初期メンバーの中で最も活躍。在籍中にボンド／キャニオンからソロデビュー 5 「なかじ」の愛称で親しまれる 6 ニャンギラスの一員として活躍。妙に背が高い 7 週間文春タバコフォーカス事件にて脱退
尚、フィールド構成は、
会員番号 数値型 主キー 備考 テキスト型
なっています。
qry1 内容は、以下のsqlです。
SELECT table1.会員番号, table1.氏名, table1.出身, table1.血液型, tbl1.備考 FROM table1 LEFT JOIN tbl1 ON table1.会員番号 = tbl1.会員番号;
尚、上記のtable1とは、sample1.xlsのSheet1のデータをインポートするテーブルです。
qry1により、table1とtbl1の同じ会員番号のデータを結合します。
その結果をsample2.xlsのqry1というシートに出力するという仕様です。 正常に作動すれば、sample2.xlsのqry1というシートには、
Ａ Ｂ Ｃ Ｄ Ｅ 1 会員番号 氏名 出身 血液型 備考 2 1 奥田 美香 東京都 Ａ型 週間文春タバコフォーカス事件にて脱退 3 2 榎田 道子 東京都 ＡＢ型 週間文春タバコフォーカス事件にて脱退 4 3 吉野 佳代子 埼玉県 Ｏ型 週間文春タバコフォーカス事件にて脱退 5 4 新田 恵利 埼玉県 Ｏ型 初期メンバーの中で最も活躍。在籍中にボンド／キャニオンからソロデビュー 6 5 中島 美春 東京都 Ａ型 「なかじ」の愛称で親しまれる 7 6 樹原亜紀 神奈川県 ＡＢ型 ニャンギラスの一員として活躍。妙に背が高い 8 7 友田 麻美子 東京都 Ａ型 週間文春タバコフォーカス事件にて脱退
という結果が得られるはずです。
次投稿にて、サンプルデータを作成するコードを提示します。
（ichinose） 2014/09/06(土) 20:35
新規ブックの標準モジュール（Module1）に以下のDB作成プログラムパック
'==============================================================================
Private cat As Object 'ADOX.Catalog
Function create_cat(flnm As String) As Long
On Error Resume Next
Set cat = CreateObject("ADOX.Catalog")
cat.Create "Provider=Microsoft.jet.OLEDB.4.0;" & _
"Data Source=" & flnm
create_cat = Err.Number
On Error GoTo 0
End Function
'=================================================================
Function get_cn() As Object
Set get_cn = cat.ActiveConnection
End Function
'=================================================================
Function cr_cmd(text As String, nm As String) As Long
On Error Resume Next
cr_cmd = 0
cat.Views.Delete nm
Err.Clear
Dim cmd As Object
Set cmd = CreateObject("adodb.command")
cmd.CommandText = text
cat.Views.Append nm, cmd
cr_cmd = Err.Number
On Error GoTo 0
End Function
'===================================================================
Sub close_cat()
On Error Resume Next
cat.ActiveConnection.Close
Set cat = Nothing
On Error GoTo 0
End Sub
標準モジュール（Module2）に
'=====================================================================
Option Explicit
Sub mk_smp_data()
mk_xls
mk_mdb
End Sub
'==========================================================================
Sub mk_xls()
On Error Resume Next
Kill ThisWorkbook.Path & "\sample1.xls"
On Error GoTo 0
With Workbooks.Add
.Worksheets(1).Name = "Sheet1"
With .Worksheets(1)
.Range("a1:d1").Value = Array("会員番号", "氏名", "出身", "血液型")
.Range("a2:d8").Value = Evaluate("{1,""奥田美香"",""東京都"",""Ａ型"";2,""榎田道子"",""東京都"",""ＡＢ型"";" & _
"3,""吉野佳代子"",""埼玉県"",""Ｏ型"";4,""新田恵利"",""埼玉県"",""Ｏ型"";" & _
"5,""中島美春"",""東京都"",""Ａ型"";6,""樹原亜紀"",""神奈川県"",""ＡＢ型"";" & _
"7,""友田麻美子"",""東京都"",""Ａ型""}")
End With
If Val(Application.Version) > 11 Then
.SaveAs ThisWorkbook.Path & "\sample1.xls", 56
Else
.SaveAs ThisWorkbook.Path & "\sample1.xls"
End If
.Close
End With
End Sub
'==================================================================================
Sub mk_mdb()
Dim sql_str As String
Dim retcode As Long
Dim cn As Object
Dim biko As Variant
Dim g0 As Long
On Error Resume Next
Kill ThisWorkbook.Path & "\dbsamp.mdb"
On Error GoTo 0
If create_cat(ThisWorkbook.Path & "\dbsamp.mdb") = 0 Then
Set cn = get_cn
sql_str = _
"CREATE TABLE tbl1 (会員番号 integer CONSTRAINT tkey PRIMARY KEY ,備考 varchar(255));"
cn.Execute sql_str
biko = Array("週間文春タバコフォーカス事件にて脱退", "週間文春タバコフォーカス事件にて脱退", "週間文春タバコフォーカス事件にて脱退", _
"初期メンバーの中で最も活躍。在籍中にボンド／キャニオンからソロデビュー", "「なかじ」の愛称で親しまれる", "ニャンギラスの一員として活躍｡妙に背が高い", _
"週間文春タバコフォーカス事件にて脱退")
For g0 = LBound(biko) To UBound(biko)
sql_str = " INSERT INTO tbl1 " _
& "(会員番号,備考) VALUES " _
& "(" & (g0 + 1) & ",'" & biko(g0) & "');"
cn.Execute sql_str
Next
cr_cmd "SELECT Table1.会員番号, 氏名, 出身, 血液型, 備考 FROM table1 LEFT JOIN tbl1 ON table1.会員番号 = tbl1.会員番号;", "qry1"
close_cat
End If
End Sub
一度、適当なフォルダに保存(VBAsamp.xls)してから、mk_smp_dataを実行してみてください。
上記ブックを保存したフォルダにsample1.xlsとdbsamp.mdbが作成されるはずです。
作成されていたなら、前投稿のようなデータが作成されているか 確認してください。
確認が出来たなら、dbsamp.mdbの標準モジュールにアクセスを使って以下のコードを 作成してください。
Option Compare Database
Option Explicit
Function Fnインポート()
On Error Resume Next
Dim Active_mdb As String
Dim varac As Variant
Dim varxls As Variant
Active_mdb = CurrentProject.Path
varac = "table1"
varxls = Active_mdb & "\sample1.xls"
DoCmd.DeleteObject acTable, varac
Err.Clear
DoCmd.TransferSpreadsheet acImport, 8, varac, varxls, True, "Sheet1!"
If Err.Number <> 0 Then
MsgBox Err.Description & " : " & Err.Number
End If
On Error GoTo 0
End Function
Function Fnエクスポート()
On Error Resume Next
Dim Active_mdb As String
Dim varac As Variant
Dim varxls As Variant
Active_mdb = CurrentProject.Path
varxls = Active_mdb & "\sample2.xls"
DoCmd.TransferSpreadsheet acExport, 8, _
"qry1", varxls, True
If Err.Number <> 0 Then
MsgBox Err.Description & " : " & Err.Number
End If
End Function
これは、あやさんが投稿されたものと殆ど同じコードをサンプル仕様用に変えたものです。
尚、アクセスがない場合は、上記のコードは、入れられません。
アクセスアプリを使った場合との対比はできませんが、ExcelVBAで仕様の実行は可能です。
では、次投稿にて、サンプル仕様を実行するコードです。
（ichinose） 2014/09/06(土) 21:03 訂正
では、実際の実行コードです。先にサンプルデータ作成プロフラムを入れたVBAsamp.xlsの 標準モジュール（Module3）にADO関連Ｉ／Ｏパック
'==========================================================================
Option Explicit
Private cn As Object
'==========================================================================
Function open_db(dbpath As String, Optional prv As Long = 0) As Long
On Error GoTo err_open_db
open_db = 0
Set cn = CreateObject("ADODB.Connection")
If prv = 0 Then
cn.ConnectionString = "provider=Microsoft.jet.OLEDB.4.0;" & "Data Source=" & dbpath
Else
cn.ConnectionString = "Provider=Microsoft.Ace.OLEDB.12.0;" & "Data Source=" & dbpath
End If
cn.Open
On Error GoTo 0
Exit Function
err_open_db:
MsgBox Error(Err.Number) & Err.Number
open_db = Err.Number
End Function
'==========================================================================
Sub close_db()
On Error Resume Next
cn.Close
Set cn = Nothing
On Error GoTo 0
End Sub
'==========================================================================
Function execute_sql(sql As String, Optional grs As Object = Nothing, Optional er As Boolean = False) As Long
On Error GoTo err_sql
close_rs grs
execute_sql = 0
If grs Is Nothing Then
cn.Execute sql
Else
grs.Open sql, cn, 2, 2
End If
On Error GoTo 0
Exit Function
err_sql:
If er Then MsgBox Err.Description & " : " & Err.Number
execute_sql = Err.Number
End Function
'==========================================================================
Sub close_rs(grs As Object)
On Error Resume Next
grs.Close
End Sub
別の標準モジュール（Module4）に
'==========================================================================
Option Explicit
Sub test1()
Dim straccesspath As String
Dim objaccess As Object
'エクセル モジュールに記述
'Accessにインポート＆★チェック.xlsにエクスポート
straccesspath = ThisWorkbook.Path & "\dbsamp.mdb"
Set objaccess = CreateObject("Access.Application")
objaccess.Opencurrentdatabase straccesspath
objaccess.Run "Fnインポート"
objaccess.Run "Fnエクスポート"
objaccess.closecurrentdatabase
objaccess.Quit
Set objaccess = Nothing
End Sub
'==========================================================================
Sub test2()
Dim rs As Object
Dim sql As String
On Error Resume Next
Kill ThisWorkbook.Path & "\sample2.xls"
On Error GoTo 0
If open_db(ThisWorkbook.Path & "\dbsamp.mdb") = 0 Then
sql = "drop Table table1;"
execute_sql sql
sql = "select * into table1 from [Excel 8.0; HDR=Yes;Database=" & ThisWorkbook.Path & "\sample1.xls" & "].[Sheet1$]"
execute_sql sql
Set rs = CreateObject("adodb.recordset")
execute_sql "select * into [Excel 8.0; HDR=Yes;Database=" & ThisWorkbook.Path & "\sample2.xls" & "].[qry1] from qry1;", , True
Call close_db
End If
End Sub
以上です。test1,test2を実行してみてください。どちらでも同じ結果（sample2.xls）が得られることを 確認してください。
test2は、本当なら、一度、mdbにsample1.xlsをインポートしなくても（Table1を作らない） 可能でしたが、今回は、test1と同じような方法で行いました。
尚、dbsamp.mdbに前投稿でのVBAコードを記述しなければ、test1は、エラーになります。 test2は、dbsamp.mdbにvbaコードがなくても作動します。
以上です。Excel2002、2010で確認しました。
うまくいくようなら、ADOの研究をしてみてください。
ただ、アクセスがないと メンテナンスは大変ですよ！！
（ichinose） 2014/09/06(土) 22:02
???さん ichinoseさん ありがとうございます 理解・検証にお時間くださいm(_ _)m
（あや） 2014/09/08(月) 10:13
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.