ExcelからAccessデータを検索するマクロ

質問

Excel、Accessとも初心者です。

下記を参考にさせて頂いております。
http://okwave.jp/qa/q441987.html

これを、(1)～(3)に対応させたいのですが
どのように書き換えればよろしいのでしょうか？

(1)A1→　A列の最後まで
(2)対応するレコードフィールド２
　　→　規定した複数のレコードフィールド
　　　　（例えば、フィールド3とフィールド5とフィールド8）
(3)Excel, Accessともに2007です。
(4)検索の経過は表示させない
　（少しでも早く処理したい。ひとつひとつ検索結果を表示すると遅くなると聞ききました）

・・・・・・・・・・・・・・・・・・・・・・・・・

Sub Macro1()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = OpenDatabase("c:\abc.mdb")
Set rs = db.OpenRecordset("tbl_a", dbOpenDynaset)
rs.FindFirst "[フィールド１]='" & Range("A1").Value & "'"
If rs.NoMatch Then
　　Range("B1").Value = ""
Else
　　Range("B1").Value = rs![フィールド２]
End If
rs.Close
Set rs = Nothing
Set db = Nothing
End Sub

・・・・・・・・・・・・・・・・・・・・・・・・・

よろしくご教授お願いします。

回答No.2

30246kiku

ADO を使った別の例で

テーブル「TBL_A」があって、フィールドは以下になっているとします
id、氏名、ふりがな、郵便番号、住所、生年月日、性別

ここで、Sheet1 の A列に抽出したい id を見出しなし/重複なしで記述していたとします。
id が一致した際に、氏名, 生年月日, 性別　の３つを書き出したいと仮定します。

SQLの中で、本ExcelファイルのSheet1 A列を抽出条件として参照します。
絞り込んだ抽出になるので、抽出した方からA列内を探すようになります。

Public Sub Samp1()
　　Dim cn As Object, rs As Object
　　Dim sMyPath As String, sSql As String
　　Dim v As Variant
　　Dim i As Long
　　Const CPATH As String = "アクセスファイルのフルパス"

　　sMyPath = ThisWorkbook.FullName
　　Worksheets("Sheet1").Select
　　Columns("B:D").ClearContents

　　Set cn = CreateObject("ADODB.Connection")
　　cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & CPATH & ";"
　　sSql = "SELECT id, 氏名, 生年月日, 性別 FROM TBL_A WHERE id IN (" _
　　　　& "SELECT F1 FROM [Sheet1$] IN '" & sMyPath & "'[EXCEL 12.0 XML;HDR=NO]);"
　　Set rs = cn.Execute(sSql)
　　While (Not rs.EOF)
　　　　v = WorksheetFunction.Match(rs(0).Value, Columns(1), 0)
　　　　If (IsNumeric(v)) Then
　　　　　　For i = 2 To 4
　　　　　　　　Cells(v, i).Value = rs(i - 1).Value
　　　　　　Next
　　　　End If
　　　　rs.MoveNext
　　Wend
　　rs.Close: Set rs = Nothing
　　cn.Close: Set cn = Nothing
End Sub

お礼

30246kiku 様
お礼が遅くなり申し訳けございません。

ADOという言葉を聞いたことがありましたが、
目にしたのは初めてです。

これを機会に勉強したいと思います。

このたびは、ありがとうございました。

回答No.1

keithin

そのまま流用してみます
参照設定などの準備は、ご覧になった過去ログのその通りに間違いなく実施してから行います
言わずもがなですがテーブル名やフィールドなども、実際に合わせて修正してから実行します

Sub Macro1()
　Dim db As DAO.Database
　Dim rs As DAO.Recordset

　dim r as long

　Set db = OpenDatabase("c:\abc.mdb")
　Set rs = db.OpenRecordset("tbl_a", dbOpenDynaset)

　application.screenupdating = false
　for r = 1 to cells(rows.count, "A").end(xlup).row
　　rs.FindFirst "[フィールド１]='" & cells(r, "A").Value & "'"

　　If rs.NoMatch Then
　　　cells(r, "B").Value = ""
　　　cells(r, "C").Value = ""
　　　cells(r, "D").Value = ""
　　Else
　　　cells(r, "B").Value = rs![フィールド３]
　　　cells(r, "C").Value = rs![フィールド５]
　　　cells(r, "D").Value = rs![フィールド８]
　　End If

　next r
　application.screenupdating = true

　rs.Close
　Set rs = Nothing
　Set db = Nothing
End Sub

補足

keithin 様

お礼が遅くなり、申し訳けございません。
おかげさまでうまくいきました。

捕捉で教えて頂きたいことがあります

Access側のレコードフィールド１にエクセルで検索したい文字が複数含まれています。（例えば、同姓同名が複数人いますが、一人ひとりの出身地は異なる場合など）

そこで、検索文字列をレコードフィールド１の上から順に検索し、最初に一致した文字列に対応するレコードフィールド２を返したいのです。

今の状態では上から何番目かのレコードを検索しているようです。
よろしくお願いいたします。