MSアクセスのDBからエクセルのVBAで情報を抽出する

質問

いつもお世話になります。

以下のフォーマットでアクセスに十数万行のデータがあります。
JANコード,商品名,分類1,分類2,分類3,分類4

そして、エクセルのSheet1のA列に、数百から数千のJANコードが並んでいるのですが、マクロを起動させることによって、B列以降に、同じJANコードの商品名から分類4までをVLOOKUP関数のようにくっつけたいのですが、そのようなことは可能でしょうか。

尚、エクセルファイルとアクセスファイルは、同じフォルダに保存されているとします。

回答No.3

O_cyan · ベストアンサー

Access側で下記のクエリを作りAccessからExcelに出力する方が簡単だと思いますが。
AccessのテーブルにSheet1をリンクして
（JANコードTblはJANコードの入ったテーブル名にしてください）

SELECT Sheet1.JANコード, JANコードTbl.商品名,JANコード.分類1, JANコードTbl.分類2,JANコードTbl.分類3,JANコードTbl.分類4
FROM Sheet1 LEFT JOIN JANコードTbl ON Sheet1.JANコード=JANコードTbl.JANコード;

このクエリでお望みのものができるはずなのでこのクエリからExcelへエクスポートすれば簡単なのですが・・。

お礼

御礼が遅くなりまして申し訳ございませんでした。
使う人が、アクセスが全く使えないことを前提としていたので、この方法は思いつきませんでしたが、確かにこちらだと簡単に目当てのものが作成できそうです。
ありがとうございました。

回答No.4

komet163

こんにちは、まだ閉じていなかったので書込みます。
流れは、
・mdb ファイルに、現在のシートのリンクテーブルを作成
・クエリの結果を B2 セル以下 に書込み
・終了時にリンクテーブルを削除
です。
動作には DAO への参照設定が必要です。
手続が長いですが、処理の流れとしては１手順です。

大きなアクセスファイルがないので、何万レコードもあるときの動作は不明です。

Sub main()

Const sSht As String = "Sheet1"
Const sDB As String = "db1.mdb"
Const sLnkTbl As String = "xlリンクTBL"
Const sSouTbl As String = "JANコードTBL"
Const StartRow As Long = 2
Const StartColumn As Long = 2

Dim daoDB As DAO.Database
Dim tdNew As DAO.TableDef
Dim daoRS As DAO.Recordset
Dim i As Long
Dim sQuery As String

'DAO で接続しリンクテーブルを作成
Set daoDB = DBEngine.OpenDatabase(ThisWorkbook.Path & "\" & sDB)
Set tdNew = daoDB.CreateTableDef(sLnkTbl)
With tdNew
.SourceTableName = sSht & "$"
.Connect = "Excel 8.0;Database=" & ThisWorkbook.FullName
End With
daoDB.TableDefs.Append tdNew

'レコードセットの作成
sQuery = _
"SELECT sSouTbl.商品名, sSouTbl.分類1, sSouTbl.分類2, sSouTbl.分類3, sSouTbl.分類4 " & _
"FROM sLnkTbl LEFT JOIN sSouTbl ON xlリンクTBL.JANコード = sSouTbl.JANコード;"
sQuery = Replace(sQuery, "sSouTbl", sSouTbl)
sQuery = Replace(sQuery, "sLnkTbl", sLnkTbl)
Set daoRS = daoDB.OpenRecordset(sQuery, dbOpenSnapshot)

With Worksheets(sSht)

'シートのクリア
.Range(.Columns(StartColumn), .Columns(StartColumn + daoRS.Fields.Count - 1)).ClearContents

'ヘッダの書込み
For i = 0 To daoRS.Fields.Count - 1
.Cells(StartRow - 1, StartColumn + i) = daoRS.Fields(i).Name
Next

'レコードセットの書込み
.Cells(StartRow, StartColumn).CopyFromRecordset daoRS

End With

'リンクテーブルの削除
daoDB.TableDefs.Delete sLnkTbl

daoRS.Close
daoDB.Close
Set daoRS = Nothing
Set daoDB = Nothing

End Sub

お礼

ありがとうございました。
まだ試していないのですが、早速行ってみます。

回答No.2

Wendy02

PCのパワーにもよるけれども、一応、参照設定してくださいね。オートメーション・オブジェクトもあり、なんですが、それでできるかは不安材料が残ります。

それと、きちんと、フィールド名があっていればよいけれど、そうでないと、ちょっと無理です。かならず、DBから、きちんと確認してください。一応、SQLのJANコードの検索は、Like演算子を使いました。

私は、こういうのは実践ではやったことがないので、十分注意してお使いください。
また、こういうDBからの引き出しの得意な専門家もいるようですから、私のは、うまく行ったら、という感じです。こちらの方は、まだまだ修行中です。コードは私のオリジナルです。（無責任ですみません）

最初に、コードに必要な部分（要入力）を登録してからお使いください。

'<標準モジュール>でお使いください。
Sub AdoExtract()
'要:参照設定 Microsoft ActiveX Data Objects ?.? Library
Dim myConn As ADODB.Connection
Dim myDBFname As String
Dim Connstring As String
Dim mySQL As String
Dim Parameter As String
Dim i As Long
'JANコード,商品名,分類1,分類2,分類3,分類4
Const myTable As String = "テーブル名"　'要入力
Const myField1 As String = "JANコード"
Const myField2 As String = "商品名"
Const myField3 As String = "分類1"
Const myField4 As String = "分類2"
Const myField5 As String = "分類3"
Const myField6 As String = "分類4"
'Check your DB Field Names Again and Db FileName
'ファイル名:要入力
myDBFname = ThisWorkbook.Path & "\" & "ファイル名"
'
mySQL = "SELECT " & myTable & "." & myField2 & "," & _
　　　　　　　　　　 myTable & "." & myField3 & "," & _
　　　　　　　　　　 myTable & "." & myField4 & "," & _
　　　　　　　　　　 myTable & "." & myField5 & "," & _
　　　　　　　　　　 myTable & "." & myField6 & " " & _
　　　　　"FROM `" & myDBFname & "`." & myTable & " " & myTable & " " & _
　　　　　"WHERE " & myTable & "." & myField1 & " " & _
　　　　　"Like'"
'
Set myConn = New ADODB.Connection
Connstring = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & _
　　　　　　　　myDBFname & ";Jet OLEDB:Database" & ";"
'
On Error GoTo DbClose
myConn.Open Connstring

For i = 2 To Range("A65536").End(xlUp).Row
　Parameter = CStr(Cells(i, 1).Value) & "' ; "
'
　With New ADODB.Recordset
　.Open mySQL & Parameter, myConn
　If .EOF Then
　　Cells(i, 2).Value = "#NA!" '見つからない場合
　 Else
　　 Cells(i, 2).Value = .Fields(myField2).Value
　　 Cells(i, 3).Value = .Fields(myField3).Value
　　 Cells(i, 4).Value = .Fields(myField4).Value
　　 Cells(i, 4).Value = .Fields(myField5).Value
　　 Cells(i, 4).Value = .Fields(myField6).Value
　End If
RsClose:
　.Close
End With
Next i
DbClose:
If Err.Number > 0 Then
　 'Err may responds
　 MsgBox Err.Number & "(" & Err.Description & ")"
　 Err.Clear
End If
myConn.Close
Set myConn = Nothing
End Sub

お礼

御礼が遅くなりまして申し訳ございませんでした。
何度か試してみたのですが、今の所途中でエラーが起こってしまい、何が悪いのか調査中です。
Wendy02さんのご丁寧に教えていただいたお心遣いを無駄にせぬよう、何とか完成させてみせます。
ありがとうございました。

回答No.1

koganeton

回答になるかどうかですが？
私の場合
アクセスＡファイル
エクセルＢファイル
とした時
中間エクセルＣファイルを作っておき
これをアクセスＡのリンクファイルにする。
エクセルＢファイルは、VLOOKUP関数で
Ｃファイルを見るようにする。

または、アクセスＡファイルの更新プロパティーで
Ｃファイルに書き出す用にマクロを設定すれば。
干渉することもなくなります。

お礼

御礼が遅くなりまして申し訳ございません。
リンクファイルというものを知らなかったので、時間がかかりましたが、いただいたご回答をもとに、何とか解決できそうです。
ありがとうございました。