• 締切済み

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

Excel、Accessとも初心者です。 下記を参考にさせて頂いております。 http://okwave.jp/qa/q441987.html これを、(1)~(3)に対応させたいのですが どのように書き換えればよろしいのでしょうか? (1)A1→ A列の最後まで (2)対応するレコードフィールド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 "[フィールド1]='" & Range("A1").Value & "'" If rs.NoMatch Then   Range("B1").Value = "" Else   Range("B1").Value = rs![フィールド2] End If rs.Close Set rs = Nothing Set db = Nothing End Sub ・・・・・・・・・・・・・・・・・・・・・・・・・ よろしくご教授お願いします。

みんなの回答

  • 30246kiku
  • ベストアンサー率73% (370/504)
回答No.2

ADO を使った別の例で テーブル「TBL_A」があって、フィールドは以下になっているとします id、氏名、ふりがな、郵便番号、住所、生年月日、性別 ここで、Sheet1 の A列に抽出したい id を見出しなし/重複なしで記述していたとします。 id が一致した際に、氏名, 生年月日, 性別 の3つを書き出したいと仮定します。 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

10samba
質問者

お礼

30246kiku 様 お礼が遅くなり申し訳けございません。 ADOという言葉を聞いたことがありましたが、 目にしたのは初めてです。 これを機会に勉強したいと思います。 このたびは、ありがとうございました。

  • keithin
  • ベストアンサー率66% (5278/7940)
回答No.1

そのまま流用してみます 参照設定などの準備は、ご覧になった過去ログのその通りに間違いなく実施してから行います 言わずもがなですがテーブル名やフィールドなども、実際に合わせて修正してから実行します 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 "[フィールド1]='" & 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![フィールド3]    cells(r, "C").Value = rs![フィールド5]    cells(r, "D").Value = rs![フィールド8]   End If  next r  application.screenupdating = true  rs.Close  Set rs = Nothing  Set db = Nothing End Sub

10samba
質問者

補足

keithin 様 お礼が遅くなり、申し訳けございません。 おかげさまでうまくいきました。 捕捉で教えて頂きたいことがあります Access側のレコードフィールド1にエクセルで検索したい文字が複数含まれています。(例えば、同姓同名が複数人いますが、一人ひとりの出身地は異なる場合など) そこで、検索文字列をレコードフィールド1の上から順に検索し、最初に一致した文字列に対応するレコードフィールド2を返したいのです。 今の状態では上から何番目かのレコードを検索しているようです。 よろしくお願いいたします。

関連するQ&A

  • DAO エクセルvbaからアクセスのレコードの件数

    DAOで、エクセルvbaからアクセスのレコードの件数を取得したいのですが Dim ac As Object Dim db As DAO.Database Dim rs As DAO.Recordset Set ac = CreateObject("Access.Application") Set db = ac.DBEngine.OpenDatabase("D:\あああ.accdb", False, True) Set rs = db.OpenRecordset("SELECT * FROM Tマスタ WHERE masterkey like '*四*';") i = rs.RecordCount Debug.Print rs("masterkey") rs.Close: Set rs = Nothing db.Close: Set db = Nothing ac.Quit: Set ac = Nothing をすると、抽出するレコードが1000件でも、必ず1が返ります。 masterkeyフィールドは文字列型です。 なぜ実際はたくさんのレコードがあるのに、1が返るのでしょうか?

  • DAOでレコード数を取得したい(ACESSVBA)

    レコードの行数は複数あるのに --------------------------------------------------------- Sub あ() Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("T_test", dbOpenDynaset) MsgBox rs.RecordCount Set rs = Nothing Set db = Nothing End Sub --------------------------------------------------------- これでレコード数を取得しようとすると1がかえるのですが なぜレコードの行数を取得できないのでしょうか?

  • ACCESS VBAからDAOを使ってのExcelファイル読み込みについて

    以前もお世話になりました。またよろしくお願いできますでしょうか。(OS: XP , Access 2003) 今回はACCESS VBA からDAOを使ってのExcelファイルの読み込みを試みています。 最初はTransferSpreadsheetを使ってうまく行っている様に見えたのですが、Quit及びSet XLApp=Nothingをちゃんとしていても、タスクマネージャーを開けると裏でEXCELが走っている状態でした。 他サイトで同じ現象の解決でAddNewが提案されており、そのサイトの例と他のDAOを使っている例を自分用にアレンジしてみました。 (他サイトのURL張っていいのかわからないので外しておきます) エラー1)Import元のファイルを開けていないと"External table is not in the expected format" でOpenDatabaseの行で止まります。これは仕様でしょうか?わざわざ Excel.Applicationなどで開けないと行けないということですか? エラー2)"Run-time error 1004. Method 'Range' of object '_Global' failed"。ファイルを開けて実行した場合Rangeの所で止まります。Public subにしたりしましたが関係なかったようです。 申し訳ありませんが、アドバイスお願い致します。 ------- Sub loadToDB() Dim rs, rs2 As DAO.Recordset Dim db As DAO.Database Dim SheetName As String Set db = OpenDatabase("U:\projects\ABC\TestFile.xls", False, False, "Excel 8.0;")   ’ファイルを開けていないとまずここで SheetName = db.TableDefs(0).Name Set rs = db.OpenRecordset(SheetName) Set rs2 = CurrentDb.OpenRecordset("TableA") Do Until rs.EOF rs2.AddNew rs!F1 = Range("A1").Value   ’ファイル開けているとここで駄目です rs!F2 = Range("B1").Value rs!F3 = Range("C1").Value rs!F4 = Range("D1").Value rs2.Update rs.MoveNext Loop rs.Close Set rs = Nothing db.Close Set db = Nothing rs2.Close Set rs2 = Nothing End Sub

  • Access VBA 添付型フィールド

    Access VBAで添付型フィールドからファイル名を取りだしたいのですが、どのようにすればいいでしょうか? Private Sub Sample() Dim DB As DAO.Database Dim RS As DAO.Recordset Dim SQL As String   Set DB = CurrentDb SQL_1 = "SELECT * FROM ボランティア情報 ORDER BY 分野 & 団体名読み;" Set RS = DB.OpenRecordset(SQL_1, dbOpenDynaset) With RS   Do While Not .EOF   MsgBox (!写真.FileName)  ←ここでエラーが出ます。 .   MoveNext   Loop End With RS.Close Set RS = Nothing Set MDB = Nothing End Sub

  • EXCEL vbaからACCESSのクエリを開く

    EXCEL2010 WEBを参照してEXCEL VBAでACCESSのクエリを開くマクロを流用しました。 下記がマクロの内容です。 Private Sub Import() Dim db As ADODB.Connection Dim rs As ADODB.Recordset 'ACCDBファイルに接続します Set db = New ADODB.Connection db.Provider = "Microsoft.Ace.OLEDB.12.0" db.Open "C:\work\TEHAI.accdb" 'レコードセットを開きます Set rs = New ADODB.Recordset 'Accessのクエリを開く rs.Open Source:="TEHAI", ActiveConnection:=db If rs.EOF Then MsgBox "抽出した結果、レコードが見つかりません。" Else ' レコードをシートへ貼り付ける Range("A1").CopyFromRecordset rs End If rs.Close Set rs = Nothing Set db = Nothing End Sub これを実行すると、 抽出した結果、レコードが見つかりません。 が表示されます。 ACCESS単体でTEHAIクエリを実行したら、約3万件くらいヒットします。 EXCELマクロから実行したらACCESSからデータをもってこられません。 なぜレコードが見つかりません、 となるのでしょうか? マクロのどこがおかしいのか、教えていただきたく。 ちなみに、もともとの内容から変更したのは db.Open "C:\work\TEHAI.accdb" rs.Open Source:="TEHAI", の2ヶ所だけです。

  • DAO フィルターをかけたい エクセルです

    昨日も http://oshiete.coneco.net/qa8283354.html で質問し、nicotinism様にご回答いただいたのですが またわからなくなったので教えてください。 エクセルからアクセスでDAOで接続した時に、 フィルタをかけて該当のレコードの他のフィールドの値を返すにはどうすればいいでしょうか? ------------------------- Sub test() Dim ac As Object Dim db As DAO.database Dim DAOrs As DAO.Recordset Set ac = CreateObject("Access.Application") Set db = ac.DBEngine.OpenDatabase("PW.accdb", False, True, ";pwd=0000") Set DAOrs = db.OpenRecordset("select * from TPW") DAOrs.Filter = "サイト名 = " & "'nanaco'" MsgBox DAOrs("Password") DAOrs.Close: Set DAOrs = Nothing db.Close: Set db = Nothing ac.Quit: Set ac = Nothing End Sub ------------------------- これだとエラーにもならないけどフィルタがかかってない為、全然関係ないレコードの値を取得してしまいます。 再度ご回答いただければ助かります。 ご教授よろしくお願いします。

  • テーブルのレコードが0件時にmsg表示(アクセス)

    とてつもない初歩的な質問で すみません! フォーム1をメニュー画面として、 フォーム1にある「ボタン」を押すと テーブルにレコードが追加され、処理が走る・・・という仕様を作っています。 ですが、 このテーブルにレコードが追加されなかった=0件 の場合の回避策を どうしたら良いのかが わかりません。 ちなみに、 Private Sub ボタン_Click() On Error GoTo errmsg DoCmd.SetWarnings False Dim DB As DAO.Database Dim rs1 As DAO.Recordset Dim rs2 As DAO.Recordset Dim i As Long Set DB = CurrentDb Set rs1 = DB.OpenRecordset("テーブル1") Set rs2 = DB.OpenRecordset("テーブル2", dbOpenDynaset) rs1.MoveFirst Do Until rs1.EOF If rs1!フィールドA1 = rs1!フィールドA2 Then rs2.AddNew rs2!ID = rs1!ID rs2!フィールドA = rs1!フィールドA1 rs2!B = rs1!フィールドB rs2!C = rs1!フィールドC rs2.Update End If If rs1!フィールドA1 < rs1!フィールドA2 Then For i = rs1!フィールドA1 To rs1!フィールドA2 Step 1 rs2.AddNew rs2!ID = rs1!ID rs2!フィールドA = i rs2!フィールドB = rs1!フィールドB rs2!フィールドC = rs1!フィールドC rs2.Update Next i End If rs1.MoveNext Loop rs1.Close: Set rs1 = Nothing rs2.Close: Set rs2 = Nothing DB.Close: Set DB = Nothing Call 次処理 errmsg: MsgBox "元データが未投入です。" End Sub としたのですが、 これでは データが投入され、処理が成功=完了した場合にも エラーメッセージが出てしまいました。 ご教示いただけますと幸いです。 お手数をおかけしますが、よろしくお願い致します。

  • ExcelVBA Accessにデータ書き込み

    VBAでコマンドボタンを押した際に特定のセルの値をAccessDBに入力するプログラムを作りたいのですが、上手くいきません...。 実行した際に「実行時エラー '21472179000 (80040e 14)': オートメーションエラーです。」と表示されます。 また、ステップインで実行してみるとEnd Withのところでエラーが発生します。 恐らくインサート文が間違っていると思うのですが、試行錯誤しても解決できませんでしたので教えて頂きたいです。 以下プログラムです。 Private Sub CommandButton1_Click() Dim cn As ADODB.Connection Dim cmd As ADODB.Command Dim rs As ADODB.Recordset Dim constr As String Dim strSQL1 As String Dim a As String a = Range("A1").Value Dim b As String b = Range("A2").Value Dim c As String c = Range("A3").Value constr = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=~.accdb strSQL1 = "insert into " & _ "TableName (1,2,3) " & _ "values ('" + Range("A1").Value + "','" + Range("A2").Value + "','" + Range("A3").Value + "')" Set cn = New ADODB.Connection cn.ConnectionString = constr cn.Open Set cmd = New ADODB.Command With cmd .ActiveConnection = cn .CommandText = strSQL1 .Execute End With Set cmd = Nothing Set rs = Nothing cn.Close Set cn = Nothing End Sub 以上、宜しくお願い致します。

  • アクセスVBA 変数での抽出条件の書きかた

    顧客データテーブルからの抽出です。 変数を使った書き方がわかりません。 よろしくお願いします。 テーブルのレコードには [氏名]:鈴木 [telnum]:0123456789 が存在します。 Private Sub テキスト0_BeforeUpdate(Cancel As Integer) Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("顧客マスタ", dbOpenDynaset) Dim str As String str = "0123456789" rs.Filter = "[telnum] = ' " & str & " ' " Set rs = rs.OpenRecordset MsgBox (rs!氏名) ’←エラーメッセージ”カレントレコードがありません。”が出ます End Sub

  • AccessのフォームでAND検索

    Accessで今、土地物件を検索するものを作っています。 物件はテーブルに200件くらいあります。 そのテーブルのフィールドに「土地面積(坪)」と「価格」いう名前のフィールドがあるのですが、この2つは【○○~○○】という具合にフォームでボタンを押せば範囲検索が出来るようになっています。 だけど、OR条件になってしまいます。 出来れば、それをAND条件で検索できる様にしたいのです。 ソースは今このようになっています↓↓ テキスト:「tubo1」「tubo2」「kakaku1」「kakaku2」 Private Sub コマンド55_Click() Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb Set rs = db.OpenRecordset("物件情報", dbOpenDynaset) If tubo1 <> "" Then If tubo2 <> "" Then    rs.Filter = "[土地面積(坪)] >=" & tubo1 & " And [土地面積(坪)] <=" & tubo2 Else rs.Filter = "[土地面積(坪)] =" & tubo1 End If If kin1 <> "" Then If kin2 <> "" Then rs.Filter = "[価格] >=" & kakaku1 & " And [価格] <=" & kakaku2 Else rs.Filter = "[価格] =" & kakaku1 End If End If End If Set rs = rs.OpenRecordset Set Me.Recordset = rs Me.Requery Set rs = Nothing Set db = Nothing End Sub です。宜しくお願い致します。 ちなみにAccess2007です。

専門家に質問してみよう