ACCESS クエリの抽出項目をEXCELから

質問

Access2000のクエリの抽出項目をExcel2013の内容を抽出項目として指定するにはどうすればよいでしょうか。

Excelには、
佐藤
田中
鈴木
.........
のように縦に名前が最大18名分入っています。

この（最大）18名の名前をAccessの抽出項目とします（フィールドは10あってその6番目に抽出項目を18名分入力したいのです）。
18名を一人一人コピペしていたのですが、何とか簡素化できないものかな？と思っています。

できれば、マクロで一発で抽出項目を貼り付けたいのですが。
よろしくお願いします。

回答No.8

30246kiku · ベストアンサー

＃７です

修正量がそう多くなかったので回答してみます。

修正点
・ハイパーリンクしない
・出来上がるシート名は「1R」「2R」・・・「xR」
・抽出内容が無くてもシートは初期化する
・騎手名は C1 から始まり、終了は空白が２行続いたら
　（24 に限定せず、書かれていた分を処理する）

Public Sub Samp2()
　　Dim cn As Object, rs As Object
　　Dim sSql As String, sS As String
　　Dim v As Variant
　　Dim iRow As Long, iRowN As Long, iR As Long
　　Dim i As Integer
　　Const adStateOpen = 1
　　Const PN2007 As String = "Microsoft.ACE.OLEDB.12.0"
　　Const PN2003 As String = "Microsoft.Jet.OLEDB.4.0"
　　Const CMDB As String = "\2014.mdb"
　　Const CSQL = "SELECT * FROM 2014 WHERE 騎手名 IN ('{%1}');"

　　On Error Resume Next
　　Set cn = CreateObject("ADODB.Connection")
　　For Each v In Array(PN2007, PN2003)
　　　　cn.Open "Provider=" & v _
　　　　　　& ";Data Source=" & ThisWorkbook.Path & CMDB
　　　　If (cn.State = adStateOpen) Then Exit For
　　Next
　　If (IsEmpty(v)) Then
　　　　MsgBox "環境不足で処理中断", vbCritical
　　　　Set cn = Nothing
　　　　Exit Sub
　　End If
　　On Error GoTo 0

　　Application.ScreenUpdating = False
　　With Worksheets("SheetDB")
　　　　iR = 1
　　　　iRow = 1
　　　　While (.Cells(iRow, "C") <> "")
　　　　　　iRowN = iRow
　　　　　　With .Cells(iRow, "C")
　　　　　　　　If (.Offset(1) <> "") Then iRowN = .End(xlDown).Row
　　　　　　　　v = WorksheetFunction.Transpose(.Resize(iRowN - iRow + 1))
　　　　　　End With
　　　　　　If (IsArray(v)) Then
　　　　　　　　sSql = Replace(CSQL, "{%1}", Join(v, "','"))
　　　　　　Else
　　　　　　　　sSql = Replace(CSQL, "{%1}", v)
　　　　　　End If

　　　　　　sS = iR & "R"
　　　　　　For Each v In Worksheets
　　　　　　　　If (v.Name = sS) Then Exit For
　　　　　　Next
　　　　　　If (IsEmpty(v)) Then
　　　　　　　　With Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　　　　　　　　　.Name = sS
　　　　　　　　End With
　　　　　　Else
　　　　　　　　v.Activate
　　　　　　　　Cells.ClearContents
　　　　　　End If

　　　　　　Set rs = cn.Execute(sSql)
　　　　　　If (Not rs.EOF) Then
　　　　　　　　With Range("A1")
　　　　　　　　　　For i = 0 To rs.Fields.Count - 1
　　　　　　　　　　　　.Offset(, i) = rs(i).Name
　　　　　　　　　　Next
　　　　　　　　　　.Offset(1).CopyFromRecordset rs
　　　　　　　　End With
　　　　　　End If
　　　　　　rs.Close
　　　　　　Set rs = Nothing
　　　　　　iRow = iRowN + 2
　　　　　　iR = iR + 1
　　　　Wend
　　　　.Activate
　　End With
　　cn.Close
　　Set cn = Nothing
　　Application.ScreenUpdating = True
End Sub

お礼

完璧です。
感動です。
Accessの本とネット検索で四苦八苦していましたが、Excelのマクロでできるとは考えもしませんでした。
記述内容は、少しずつ勉強していきます。
本当にありがとうございました。

回答No.7

30246kiku

＃２です

＃６さんの、お礼をみました。
> あと1点、お願いします。
と言われていますが、当初の質問内容からかけ離れているように思います。
（私の解釈違いかも？）

また、何をしたいのかわかりません。
「同じ操作」とは、どの様な操作を指すのでしょうか？

勝手に前提条件を設定して、記述の一例を・・・

条件は以下

・Access ファイル名「2014.mdb」、Excel ファイル名「hoge.xls」
・Access ファイルと、Excel ファイルは同じフォルダにある。
・Access ファイル内には、テーブル「2014」がある。
・そのテーブルには、フィールド「騎手名」（テキスト型）がある。
・Excel ファイルには、シート「SheetDB」のみ。
・Excelのシート「SheetDB」の C 列のどこかに騎手名が入っており、
　その騎手名を用いて、Access ファイル内のテーブル「2014」からデータを抽出する。
・結果は、騎手名をシート名にしたものを作成し、抽出データを書き出す。
　C 列の騎手名の所に、騎手名のシートの A1 をハイパーリンク設定する（過剰仕様？）
・なお、騎手名のシートが既にあったら、抽出データのみ書き換える。

以下を、Excel ファイル「hoge.xls」の標準モジュールに記述し実行してみる。
※ 操作は Excel ファイルで行う（ Access ファイルはデータを見るだけ）

Public Sub Samp1()
　　Dim cn As Object, rs As Object
　　Dim rng As Range, r As Range
　　Dim sSql As String, sS As String
　　Dim v As Variant
　　Dim i As Integer
　　Const adStateOpen = 1
　　Const PN2007 As String = "Microsoft.ACE.OLEDB.12.0"
　　Const PN2003 As String = "Microsoft.Jet.OLEDB.4.0"
　　Const CMDB As String = "\2014.mdb"
　　Const CSQL = "SELECT * FROM 2014 WHERE 騎手名='{%1}';"

　　On Error Resume Next
　　Set cn = CreateObject("ADODB.Connection")
　　For Each v In Array(PN2007, PN2003)
　　　　cn.Open "Provider=" & v _
　　　　　　& ";Data Source=" & ThisWorkbook.Path & CMDB
　　　　If (cn.State = adStateOpen) Then Exit For
　　Next
　　If (IsEmpty(v)) Then
　　　　MsgBox "環境不足で処理中断", vbCritical
　　　　Set cn = Nothing
　　　　Exit Sub
　　End If
　　On Error GoTo 0

　　Application.ScreenUpdating = False
　　With Worksheets("SheetDB")
　　　　Set rng = .Range("C:C").SpecialCells(xlCellTypeConstants)
　　　　For Each r In rng
　　　　　　sSql = Replace(CSQL, "{%1}", r.Value)
　　　　　　Set rs = cn.Execute(sSql)
　　　　　　If (Not rs.EOF) Then
　　　　　　　　For Each v In Worksheets
　　　　　　　　　　If (v.Name = r.Value) Then Exit For
　　　　　　　　Next
　　　　　　　　If (IsEmpty(v)) Then
　　　　　　　　　　With Worksheets.Add(After:=Worksheets(Worksheets.Count))
　　　　　　　　　　　　.Name = r.Value
　　　　　　　　　　　　r.Parent.Hyperlinks.Add r, "", .Name & "!A1"
　　　　　　　　　　End With
　　　　　　　　Else
　　　　　　　　　　v.Activate
　　　　　　　　　　Cells.ClearContents
　　　　　　　　End If
　　　　　　　　With Range("A1")
　　　　　　　　　　For i = 0 To rs.Fields.Count - 1
　　　　　　　　　　　　.Offset(, i) = rs(i).Name
　　　　　　　　　　Next
　　　　　　　　　　.Offset(1).CopyFromRecordset rs
　　　　　　　　End With
　　　　　　End If
　　　　　　rs.Close
　　　　　　Set rs = Nothing
　　　　Next
　　　　Set rng = Nothing
　　　　.Activate
　　End With
　　cn.Close
　　Set cn = Nothing
　　Application.ScreenUpdating = True
End Sub

私からは以上です

補足

今回いただいた、マクロ。正直感動しました。ExcelでAccessを操作できるんですね。さらに
リンクされていてデータが表示されるなんて、驚きました。

>「同じ操作」とは、
Excelにある
　　 1-4（柴山～黛まで）をAccessから抽出し、ExcelのSheet1に貼り付け、
次に 6-7（吉田～浜名まで）をAccessから抽出し、ExcelのSheet2に貼り付け、
次に10-12（大野～岩田まで）をAccessから抽出し、ExcelのSheet3に貼り付け、
.........
といった作業を24回行いたいのです。
1行目から空白行の手前まで、次の空白行の手前まで（レース別）、を繰り返したいのです。
1-5行目は、処理が終われば削除しても構いません。各レース最大18名、最少4名います。
何人かが不規則なので空白行で区切った？つもりです。
よろしくお願い致します。

1柴山雄一　
2伊藤工真 第１レース
3松岡正海
4黛弘人
5
6吉田豊
7北村宏司　　　　 第2レース
8浜中俊
9
10大野拓弥
11赤岡修次 第3レース
12岩田康誠
13
14石川裕紀人 第4レース
・・・・・・・・・

回答No.6

NotFound404

問題なさげですけどねぇ。
もしかしたらパスにスペースが入っているから・・・
JRA Data
Access DB
を
JRAData
AccessDB
とか
JRA_Data
Access_DB
にしてみたら。。。
これで解決できなければ降参です。

お礼

あと1点、お願いします。
C:\JRA\Accessに
「2014.mdb」と「出馬表当日.xls」が保存されています。
「出馬表当日.xls」のデータを抽出項目として使用します。

「出馬表当日.xls」のSheetDBのC列に、以下のようにAccessの抽出項目としたい騎手名が並んでいます。
まず1～4人、次に6～8、その次が10～12と空白行ごとに抽出して、その結果を「出馬表当日.xls」にシートを変えて貼り付けたいのです。
同じ操作を24回行います。（Sheet1～24までに保存）
教えていただいたSQLで24回繰り返すのを簡素化したいのですが、御教示いただけないでしょうか。
何度もすみませんが、よろしくお願い致します。

1柴山雄一
2伊藤工真
3松岡正海
4黛弘人
5
6吉田豊
7北村宏司
8浜中俊
9
10大野拓弥
11赤岡修次
12岩田康誠
13
14石川裕紀人

・・・・・・・・・

補足

何度もありがとうございます。
パスのスペースも変更したり、フォルダを簡潔にしたりとしても駄目でしたが、...が、.......
申し訳ありません。
エクセルのセルの書式を数値に変更したら、問題なく作動しました。
私の無知でみなさまにご迷惑をお掛けし、申し訳ありませんでした。
いろいろ本を読んだり、検索したりして、ほんの少しACCESSをかじることができました。
もう少し勉強したいと思います。
ひとまずお礼まで。

回答No.5

NotFound404

えーとですね。
私の回答のVBAでの処理でエラーになったのではなく、
#2 さんの回答の
SELECT * FROM ★★
WHERE 氏名 IN (SELECT * FROM [Sheet1$C1:C18] IN 'D:\Hoge\hoge.xls'[Excel 8.0;HDR=NO]);
を書き換えて試そうとしたが、
>SQLステートメントが正しくありません。
>'DELETE''INSERT''PROCEDURE''SELECT'または'UPDATE'を使用してください
とエラー表示されたということでしょうか？
であれば、その実際のSQL文をそのまま提示してください。

補足

Access、理解が乏しく申し訳ありません。

SELECT *
FROM 2014
WHERE 騎手名 IN (SELECT * FROM [Sheet1$C1:C18] IN 'C:\JRA Data\Access DB\Book1.xls'[Excel 8.0;HDR=NO]);

回答No.4

NotFound404

>クエリの保存ができません
クエリは表示されたのでしょうか？
エラーメッセージからするとそうでも無さそうですね。

前回のコードのお終いの方に

～前略
qTmp.SQL = sSql
debug.print qtmp.sql '追加します
DoCmd.OpenQuery "Q_XL" '※
End Sub

で、Ctrl + G でイミディエイトウィンドウが出ますので
そこに
SELECT [2014].ID, [・・・・・とか何かあるかと思いますので
それを提示してみてください。

補足

ありがとうございます。

>クエリは表示されたのでしょうか？
#2さんのクエリを書き換えて保存しようとしたらエラーになりました。

下に表示されたイミディエイトウィンドウには何も書かれていません。

左上に
プロジェクト-New Data

その2行下に
New Data(2014)]

とあります。

よろしくお願いします。

回答No.3

NotFound404

では、
C:\TEMPフォルダに123.xls
Sheet2のC1～Cxxに連続して○×がある
Q_XL という名のクエリ（中身はテキトーで可）がある
という仮定の下です。
下記モジュールを実行してみてください（ダメ元で）。
※は変更が必要な部分です。

Sub XLQ()
Dim oXl As Object
Dim r As Variant, rEnd As String
Dim i As Integer
Dim sWhere As String, sSql As String
Dim qTmp As DAO.QueryDef
Set oXl = CreateObject("excel.application")
oXl.workbooks.Open "c:\temp\123.xls", ReadOnly:=True '※ファイルパス
rEnd = CStr(oXl.workbooks("123.xls").worksheets("sheet2").Range("C:C").End(-4121).Row) '※ファイル名、シート名、セル列名
r = oXl.workbooks("123.xls").worksheets("sheet2").Range("c1:C" & rEnd) '※ファイル名、シート名、セル列名

sWhere = "'"
For i = 1 To UBound(r)
sWhere = sWhere & r(i, 1) & "','"
Next
sWhere = Left(sWhere, Len(sWhere) - 2)
oXl.Quit
Set oXl = Nothing

sSql = "SELECT [2014].ID, [2014].レースID, [2014].芝0・ダ1, [2014].平地0・障害1, [2014].距離, [2014].騎手名, [2014].調教師名, [2014].人気, [2014].単勝オッズ, [2014].着順, [2014].開催 FROM 2014"
sSql = sSql & " WHERE 開催地 in (" & sWhere & ")" '※フィールド名は開催地？
Set qTmp = CurrentDb.QueryDefs("Q_XL") '※Q_XL という名前のクエリは適当に
qTmp.SQL = sSql
DoCmd.OpenQuery "Q_XL" '※
End Sub

末尾ながら、
#2さんのご回答で問題ないことが当方では確認できました。Office2010 & Office2002

補足

ご回答ありがとうございます。
次のメッセージが出て、クエリの保存ができません。

SQLステートメントが正しくありません。
'DELETE''INSERT''PROCEDURE''SELECT'または'UPDATE'を使用してください。

よろしくお願いします。

回答No.2

30246kiku

> Access2000のクエリの抽出項目をExcel2013の内容を抽出項目

これは、Excel の拡張子 xls 以外では無理だと思います。
（2000 で、xlsx, xlsm 等を解釈できるとは思えない）

Excel ファイルが、D:\Hoge\hoge.xls で、
その中の Sheet1 の C1:C18 に氏名が入っていたとして、
テーブル「★★」内の、「氏名」フィールドに対して絞り込みするのであれば、
雰囲気、以下の様になるかも

クエリのSQLビューで記述します

SELECT * FROM ★★
WHERE 氏名 IN (SELECT * FROM [Sheet1$C1:C18] IN 'D:\Hoge\hoge.xls'[Excel 8.0;HDR=NO]);

※ 動かなかったら、スルーしてください

補足

ありがとうございます。
私の記述がまずいのか以下のメッセージが出ます。
「このテーブルには、このスプレッドシートで定義されている範囲外のセルが含まれています。」
よろしくお願いします。

回答No.1

NotFound404

さすがにマクロでクエリのデザイングリッドに貼り付ける方法は有りません。（多分）
VBAでクエリのSQL文を書き換えることなら出来ます。
VBAでも構わなければ
仮定として
C:\TEMPフォルダに123.xls
Sheet2のC1～Cxxに連続して氏名がある
テーブル名をTbl
現在のクエリ名をQ1
抽出条件を設定したいフィールド名をF6
を考えてみましたが、
そのクエリのSQL文が回答上欲しいです。

当方Office2010ですので
Access2000 & Excel2013 での検証不可です。
バージョン違いのためにエラーになり、途中でギブアップするかもしれません。
ダメ元で試されるのならクエリのSQL文をどうぞ。
（フィールド名など公開したくない部分があれば適宜ぼかしてください）

補足

ありがとうございます。以下でよろしいでしょうか？（SQL文が全く分からないもので）
SELECT [2014].ID, [2014].レースID, [2014].芝0・ダ1, [2014].平地0・障害1, [2014].距離, [2014].騎手名, [2014].調教師名, [2014].人気, [2014].単勝オッズ, [2014].着順, [2014].開催
FROM 2014
WHERE ((([2014].開催)="京都"));