Excel→Access ADO接続

質問

お世話になります
■ExcelからAccessに接続し社員Noを入力すると氏名が表示するように
したいのですが。

■Access側
社員管理.mdb
社員DB
ID|社員No|社員名|
社員Noで検索させます
社員Noはランダムです　例:0001002200　例2:aあ0021aう001

■Excel側
C5以下社員No入力欄（セル結合していますC5:J5）
K5以下社員名表示欄（セル結合していますK5:X5)
社員No入力後Accessから値を取り出し社員名に名前が値が飛ぶようにしたい
社員No入力してもヒットしない場合は決められたエラー文字を入力させたい。
宜しくお願いいたします。
尚、Excelファイルすべてのワークシートに適用させたい

分かる方、宜しくお願い申し上げます

回答No.5

KenKen_SP · ベストアンサー

#2, 4 です。連投すみません。

ThisWorkbook モジュールでやる場合の参考コードです。違いは、

　・SQL で問い合わせする手法になっています
　・複数セルが一度に更新された場合も対応します

ぐらいですけど、都度 DB に問い合わせているので処理速度は遅いですね。
ご参考までということで。

　# ご紹介した URL もじっくり目を通してみて下さい

Option Explicit

' // データベース周りの定数
Private Const DB_CONNECTION_STR　 As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Private Const DB_FILEPATH　　　　 As String = "C:\社員管理.mdb" ' // mdbのフルパス
Private Const DB_NOTFOUND_MESSAGE As String = "Not Found."　　　' // エラー時

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

　　' // Require: Microsoft ActiveX Data Objects 2.x Library

　　Dim cn　　As ADODB.Connection
　　Dim rs　　As ADODB.Recordset
　　Dim rCode As Range
　　Dim r　　 As Range
　　Dim sql　 As String
　　Dim sCode As String
　　Dim sRet　As String

　　On Error Resume Next
　　Set rCode = Range(Sh.Cells(5, "C"), Sh.Cells(Rows.Count, "C"))
　　Set rCode = Intersect(Target, rCode)
　　Set rCode = Intersect(rCode, Sh.UsedRange)
　　If rCode Is Nothing Then Exit Sub

　　On Error GoTo Err_
　　' // データベースに接続
　　Set cn = CreateObject("ADODB.Connection")
　　cn.Open DB_CONNECTION_STR & DB_FILEPATH
　　' // データベース問い合わせ
　　Set rs = CreateObject("ADODB.Recordset")
　　For Each r In rCode.Cells
　　　　sCode = Trim$(r.Text)
　　　　If Len(sCode) Then
　　　　　　sql = ""
　　　　　　sql = sql & "SELECT [社員名]"
　　　　　　sql = sql & " FROM [社員DB]"
　　　　　　sql = sql & " WHERE [社員No] ='" & sCode & "'"
　　　　　　sql = sql & " ORDER BY [ID]"
　　　　　　rs.Open sql, cn, adOpenKeyset, adLockReadOnly
　　　　　　' // 結果を出力
　　　　　　If rs.EOF Then
　　　　　　　　sRet = DB_NOTFOUND_MESSAGE
　　　　　　Else
　　　　　　　　sRet = rs.Fields(0).Value
　　　　　　End If
　　　　　　rs.Close
　　　　Else
　　　　　　sRet = ""
　　　　End If
　　　　Cells(r.Row, "K").Value = sRet
　　Next r

Bye_:
　　On Error Resume Next
　　Set rCode = Nothing
　　rs.Close: Set rs = Nothing
　　cn.Close: Set cn = Nothing
　　Exit Sub
Err_:
　　MsgBox Err.Description, vbCritical
　　Resume Bye_
End Sub

回答No.7

KenKen_SP

#5 です。

すみません。#5 のコードを少し訂正しておきます。

Cells(r.Row, "K").Value = sRet
　　↓
このままだと、Change イベントが多重発生するので、もしお試しに
なるのであれば、For ループの前あたりの適当な場所に

　　Application.EnableEvents = False

を入れてイベントの再発を抑止し、ラベル Bye_: 以下あたりの適当
なところに

　　Application.EnableEvents = True

を追加して下さい。

お礼

ありがとうございます
思っていたように動きました
感動しました
ありがとうございます

回答No.6

noname#140971

1、VBエディタを開く。
2、挿入(I)-標準モジュール(M) をクリック。
3、Const pubCNNSTRING～End Functionまでをコピペ。

以上で DBLookup関数が使えるようになります。
その後、DBLookup関数の使い方を[イミディエイト]でテストされたし。

なお。

Private Sub CommandButton1_Click()
　　Me.Cells(1, 1) = DBLookup("SELECT EName FROM Employee WHERE ENo='A100'")
End Sub

これで、エクセルのセルに表示できます。

ところで、質問者のやり方は、テーブル全体からサーチする方法。
DBLookup関数は、SELECT文で条件を指定して１レコードの一つの列のみを抽出する方法。
通常は、後者のやり方です。

Private Sub CommandButton1_Click()
　　Me.Cells(1, 1) = DLookup("EName", "Employee", "ENo='A100'")
End Sub

と、Access では　DLookup関数なるものが提供されています。
DBLookup関数は、このDLookup関数のADOバージョンみたいなものです。

回答No.4

KenKen_SP

#2 です。正直 DB 周りの処理は久ぶりなので、間違ってたら誰か突っ込み
入れて下さい^^；

Seek はインデックスを利用した検索です。検索するフィールドにインデックス
が設定されている必要がありますが、この点は OK ですか？

　参考URL： http://www.accessclub.jp/ado/17.html

もしインデックスが設定されていないのであれば、Find メソッドの方を利用
しなければなりません。

前提ですけども、当初のご質問本文にあるとおり、

> 社員管理.mdb　　　　　<--- mdbファイル名
> 社員DB　　　　　　　　<--- テーブル名
> ID|社員No|社員名|　　 <--- フィールド構成

とします。補足頂いた内容を修正するとこんな感じ。

Sub SetShainmei(ByVal Target As Range)

　　' // 要参照設定： Microsoft ActiveX Data Objects 2.x Library

　　Const cstDbPath　　 As String = "C:\社員管理.mdb" '// mdbのフルパス
　　Const cstTblName　　As String = "社員DB"　　　　　'// テーブル名
　　Const cstfldName　　As String = "社員名"　　　　　'// フィールド名

　　Dim cn　　　　　　　As New ADODB.Connection
　　Dim rs　　　　　　　As New ADODB.Recordset
　　Dim sCriteria　　　 As String

　　If Target.Column <> 3 Or Target.Row < 5 Or Target.Count > 1 Then
　　　　Exit Sub
　　End If

　　cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & cstDbPath
　　rs.Open cstTblName, cn, adOpenKeyset, adLockOptimistic
　　sCriteria = "[社員No] = '" & Target.Value & "'"

　　rs.Find sCriteria, , adSearchForward

　　If Not rs.EOF Then
　　　　Target.Offset(0, 8).Value = rs.Fields(cstfldName)
　　Else
　　　　Target.Offset(0, 8).Value = "Not Found!"
　　End If

　　rs.Close: Set rs = Nothing
　　cn.Close: Set cn = Nothing

End Sub

余談ですけど、、

> --------------------かくシート貼り付け--------------------
> Private Sub Worksheet_Change(ByVal Target As Range)
> 　SetShainmei Target
> End Sub

全てのシートが対象となるのであれば、ThisWorkbook モジュールの
Workbook_SheetChange イベントで良いのでは？

回答No.3

sagawa998

http://www.happy2-island.com/vbs/cafe02/capter00506.shtml
基本的なマクロについては分かるのでしょうか
MDBは誰が作ったのでしょうか
MDBに接続はできるでしょうか
SQL　SELECTはできるでしょうか
どこまでできて　どこがわからないのでしょうか
この方法はあなたの発案ですか
MDBである必要はありますか

回答No.2

KenKen_SP

参考URL: VBA応用(ADOでデータを取得する
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_130_030.html

具体的にどの点がわからないのですか？

お礼

お返事ありがとうございます
補足内容よろしくお願いします

補足

お返事ありがとうございます
下記を動かそうとしているのですが動かなくて困っています
データー型が違うのとprimarykeyではないのですが・・
修正できますか？

--------------------モジュール--------------------
Sub SetShainmei(Target As Range)

　Const cstDbPath As String = "mdbのフルパス"
　Const cstTblName As String = "テーブル名"
　Const cstfldName As String = "フィールド名"

　Dim cn As New ADODB.Connection
　Dim rs As New ADODB.Recordset

　If Target.Column <> 3 Or Target.Row < 5 Or Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then
　　Exit Sub
　End If

　cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & cstDbPath
　rs.Open cstTblName, cn, adOpenKeyset, adLockReadOnly, adCmdTableDirect
　rs.Index = "primarykey"
　rs.Seek Target.Value, adSeekFirstEQ

　If Not rs.EOF Then
　　Target.Offset(0, 8) = rs.Fields(cstfldName)
　Else
　　Target.Offset(0, 8) = Null
　End If

　rs.Close: Set rs = Nothing
　cn.Close: Set cn = Nothing

End Sub

--------------------かくシート貼り付け--------------------
Private Sub Worksheet_Change(ByVal Target As Range)
　SetShainmei Target
End Sub

回答No.1

noname#140971

<C:\Temp\Db1.mdb!Employee>

ID__ENo___EName
1___A100__鈴木 一郎
2___A101__中村 主水

[イミディエイト]
? DBLookup("SELECT EName FROM Employee WHERE ENo='A100'")
鈴木 一郎
? IIF(Len(DBLookup("SELECT EName FROM Employee WHERE ENo='A111'")), "Found!", "Not Found!")
Not Found!

これな、エクセルからAccessのデータベースにアクセスするテスト結果です。
上記の２つのテストで質問には答えているかと思います。

Option Explicit

Const pubCNNSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Temp\db1.mdb"

Public Function DBLookup(ByVal strSQL As String) As Variant
On Error GoTo Err_DBLookup
　　 Dim DataValue
　　 Dim rst As ADODB.Recordset

　　 Set rst = New ADODB.Recordset
　　 With rst
　　　　 .Open strSQL, _
　　　　　　　 pubCNNSTRING, _
　　　　　　　 adOpenStatic, _
　　　　　　　 adLockReadOnly
　　　　 If Not .BOF Then
　　　　　　 .MoveFirst
　　　　　　 DataValue = .Fields(0)
　　　　 End If
　　 End With
Exit_DBLookup:
On Error Resume Next
　　 rst.Close
　　 Set rst = Nothing
　　 DBLookup = DataValue & ""
　　 Exit Function
Err_DBLookup:
　　 MsgBox "SELECT 文の実行時にエラーが発生しました。(DBLookup)" & Chr$(13) & Chr$(13) & _
　　　　　　"・Err.Description=" & Err.Description & Chr$(13) & _
　　　　　　"・SQL Text=" & strSQL, _
　　　　　　vbExclamation, " 関数エラーメッセージ"
　　 Resume Exit_DBLookup
End Function

なお、通常は、pubCNNSTRING は外部テキストファイル（xxxxx.ini)などに定義して読み込ませるかと思います。

お礼

お返事ありがとうございます

補足

当方初心者です
省略されては分かりません
尚、
Option Explicit

Const pubCNNSTRING = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Temp\db1.mdb"
モジュール上記場所指定しなおしてもうごきません
宜しくお願いします