[三流君 ] −−＞
[ＶＢＡで楽しく ] −−＞
[バックナンバー一覧 ]Access クエリーをExcelシートへ10行x3列で出力する
メルマガ発行内容
＜Access クエリーをExcelシートへ10行x3列で出力する＞
どうも、三流プログラマーのＫｅｎ３です。
最近、質問もらうけど、
なかなか、解答できてない三流プログラマーのＫｅｎ３です。
※私のレベルで手に余る高度な質問が多くて。
今回の、サンプルファイルは、
http://www.ken3.org/vba/lzh/vba130.lzh
にdb130.mdb(Access2000版)が保存されています。
※クエリーやプログラムをいじって、遊んでみてください。
/*
* １. 今回のキッカケ
*/ http://www.ken3.org/backno/backno_vba26.html#127
[No.128 AccessにExcelのシートをインポートする]
http://www.ken3.org/backno/backno_vba26.html#128
[No.129 Access いろいろとクエリーでグループ集計をしてみる]
http://www.ken3.org/backno/backno_vba26.html#129
前回、
データを集計するクエリーまで、なんとかやりました。
パターン１ Q_YUBIN_7
郵便番号７桁（−付で８桁）、カウント１０以上
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
郵便番号 郵便番号のカウント 桁数
220-0021 14 8
---
条件は >=10(10以上) で =8(桁数は8桁)
/*
* ２．方針を考える
*/ http://www.ken3.org/backno/hosoku/e025/index.html
で、
DoCmd.TransferSpreadsheet acExport, 5, "管理MST", "C:\TEST.XLS", True, ""
＜書式付きエクスポート DoCmd.OutputToで、できます＞
http://www.ken3.org/backno/hosoku/ETC_026.html
で、
DoCmd.OutputTo acOutputTable, "T_管理MST", acFormatXLS, "C:\TEST.xls", True
を使ってました。
DoCmd.TransferSpreadsheet
や
DoCmd.OutputTo
で、AccessデータをExcelのシートに変換できるけど、
郵便番号 集計数 郵便番号 集計数 郵便番号 集計数
2280002 20 2600003 15 330005 20
2280003 15 2600004 20 330010 25
2280005 12 2600005 25 330015 12
みたいに、データをn列＊n行で出力できないので、
自分で、クエリーを読み込んで、
Excelへ出力してみたいと思います。
/*
* ３．ADOでクエリーを開いて、Excelへデータをセットする
*/ http://www.ken3.org/backno/backno_vba19.html#93
で、
チョコット解説しているけど、
Recordset を開く場合
^^^^^^^^^^^^^^^^^^^^^
DAOだと、
Dim db as Database
Dim rs as DAO.Recordset
Set db = CurrentDB()
Set rs = db.OpenRecordset("Employees")
ADOだと、
Dim rs as New ADODB.Recordset
rs.Open "社員", CurrentProject.Connection, adOpenKeySet, adLockOptimistic
らしいので、
テストで、クエリー Q_YUBIN_7 を出力してみます。
CreateObject("Excel.Application")
で、
オブジェクト作成後、
Workbooks.Addで、Excelのブックを作成
Sheets.Addで、シートを追加して、
ActiveSheet.Name = "DATA" なんて感じで、.Nameプロパティを変更。
あとは、レコードセットを開いて、
ループでレコードエンドまでデータをセットしてます。
Private Sub btnTEST001_Click()
Dim rs As New ADODB.Recordset 'ADOのレコードセット
Dim objEXCEL As Object 'Excel参照用
Dim nYLINE As Long 'セット位置
'Excelを起動する、オブジェクトの作成
Set objEXCEL = CreateObject("Excel.Application") 'オブジェクトの作成
objEXCEL.Visible = True 'Excelを見えるようにする
'新規のブックを追加する
objEXCEL.Workbooks.Add 'Excelのブックを作成
'Excelのシートを追加、シート名を変更する
objEXCEL.Sheets.Add 'シートを追加する
objEXCEL.ActiveSheet.Name = "DATA" 'シート名をDATAにする
'レコードセットを開く(Q_YUBIN_7)
rs.Open "Q_YUBIN_7", CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
'見出しの代入とカウンタの初期化
objEXCEL.Cells(1, "A") = "郵便番号"
objEXCEL.Cells(1, "B") = "件数"
nYLINE = 2 '２行目からデータをセットする
'レコードセットからExcelへデータをセットする
'ループ処理
While rs.EOF = False 'いつものEOFが偽の間
'データをセットする(Accessから転記)
objEXCEL.Cells(nYLINE, "A") = rs("郵便番号").Value
objEXCEL.Cells(nYLINE, "B") = rs("郵便番号のカウント").Value
'次を読む And カウンタを移動する
rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑)
nYLINE = nYLINE + 1 'カウンタも忘れずに＋１する
Wend
'通常は、ここでExcelを保存するんだけど、今回は開きっぱなしの手抜き
rs.Close '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
Set rs = Nothing '変数も後始末しますか。使った器はキレイにしろって?
End Sub
まぁ、縦には、なんとかセットできたよね。
でも、これって？普通に出力した時と同じジャン？
A列 B列
郵便番号 件数
107-0052 27
112-0002 27
113-0033 28
135-0034 27
135-0044 27
136-0072 28
そうですよ（開き直りか？）
/*
* ４．パズルは得意ですか？n列*n行の出力を考える
*/ '処理レコード数を増やす
If nRCNT > 10 Then '処理したレコードが10を越えた(次の列)
nXLINE = nXLINE + 3 '次の列へカウンタを移動
If nXLINE > 9 Then '列が越えた？
nXLINE = 1 '1列目（Ａ列）に戻す
nYLINE = nYLINE + 2 '空白行にしたいのでセット位置を＋２する
Else
nYLINE = nYLINE - 10 '列が変わったので行カウンタをマイナスする
End If
'見出しの表示
objEXCEL.Cells(nYLINE, nXLINE) = "郵便番号"
objEXCEL.Cells(nYLINE, nXLINE + 1) = "件数"
nYLINE = nYLINE + 1 '見出し表示分行数が増えます
nRCNT = 1 '見出し表示後は１レコード目だよ
Else '
nYLINE = nYLINE + 1 '次の行へセット位置を移動
End If
で、なんとか、
セット位置を移動しながらデータをセルにセットすることが出来きました。
Private Sub btnTEST002_Click()
Dim rs As New ADODB.Recordset 'ADOのレコードセット
Dim objEXCEL As Object 'Excel参照用
Dim nYLINE As Integer '行セット位置
Dim nXLINE As Integer '列セット位置
Dim nRCNT As Integer 'レコードカウンタ
'Excelを起動する、オブジェクトの作成
Set objEXCEL = CreateObject("Excel.Application") 'オブジェクトの作成
objEXCEL.Visible = True 'Excelを見えるようにする
'新規のブックを追加する
objEXCEL.Workbooks.Add 'Excelのブックを作成
'Excelのシートを追加、シート名を変更する
objEXCEL.Sheets.Add 'シートを追加する
objEXCEL.ActiveSheet.Name = "DATA" 'シート名をDATAにする
'レコードセットを開く(Q_YUBIN_7)
rs.Open "Q_YUBIN_7", CurrentProject.Connection, _
adOpenKeyset, adLockOptimistic
'カウンタの初期化 スタート位置のセット
nYLINE = 1 '１行目だよ
nXLINE = 1 '１列目（A列）だよ
'見出しをセットする
objEXCEL.Cells(nYLINE, nXLINE) = "郵便番号"
objEXCEL.Cells(nYLINE, nXLINE + 1) = "件数"
nYLINE = nYLINE + 1 '見出し分行数が増えます
nRCNT = 1 '見出し表示後は１レコード目だよ
'レコードセットからExcelへデータをセットする
'ループ処理
While rs.EOF = False 'いつものEOFが偽の間
'データをセットする(Accessから転記)
objEXCEL.Cells(nYLINE, nXLINE) = rs("郵便番号").Value
objEXCEL.Cells(nYLINE, nXLINE + 1) = rs("郵便番号のカウント").Value
'次を読む And カウンタを移動する
rs.MoveNext '次のレコードに移動しないと、とんでもないことに(笑)
nRCNT = nRCNT + 1 '処理レコード数を増やす
If nRCNT > 10 Then '処理したレコードが10を越えた(次の列)
nXLINE = nXLINE + 3 '次の列へカウンタを移動
If nXLINE > 9 Then '列が越えた？
nXLINE = 1 '1列目（Ａ列）に戻す
nYLINE = nYLINE + 2 '空白行にしたいのでセット位置を＋２する
Else
nYLINE = nYLINE - 10 '列が変わったので行カウンタをマイナスする
End If
'見出しの表示
objEXCEL.Cells(nYLINE, nXLINE) = "郵便番号"
objEXCEL.Cells(nYLINE, nXLINE + 1) = "件数"
nYLINE = nYLINE + 1 '見出し表示分行数が増えます
nRCNT = 1 '見出し表示後は１レコード目だよ
Else '
nYLINE = nYLINE + 1 '次の行へセット位置を移動
End If
Wend
'通常は、ここでExcelを保存するんだけど、今回は開きっぱなしの手抜き
rs.Close '開いたら閉じろ、ドアを開けたら閉めるってしつけられたでしょ(笑)
Set rs = Nothing '変数も後始末しますか。使った器はキレイにしろって?
End Sub
-【けんぞう！】---------------------------------------------------------
月500円、タバコなら２箱、120円缶コーヒーなら４缶分の謝礼をＧｅｔするなら
http://www.ken3.org/etc/500yen/ ←無料アンケート系の広告です。
『チッ、がんばって回答して月500円かよ』（お馬鹿なプログラマー：30歳）
------------------------------------------------------------------------
/*
* ５．終わりの挨拶
*/ http://www.ken3.org/vba/lzh/vba130.lzh
にdb130.mdb(Access2000版)が保存されています。
※クエリーをいじって、遊んでみてください。
何かの参考となれば幸いです。
Ｅｘｃｅｌ／Ａｃｃｅｓｓ大好き、三流プログラマーＫｅｎ３でした。
ページフッター
ここまで、読んでいただきどうもです。ここから下は、三流君のホームページの紹介・案内です
種類別のリンク や 広告など
Blogとリンク :[三流君の作業日記 ]/
[VBAやASPのサンプルコード ]/
広告-[通販人気商品の足跡 ]
三流君(TOP ken3.org へ戻る) ]
/ [VBA系TOPへ ]
/ [VBA系バックナンバー目次へ移動 ]
↑設定・実行結果イメージ
パターン２ Q_YUBIN_ETC
郵便番号７桁以外（−付で８桁以外）、カウント１０以上
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
郵便番号 郵便番号のカウント 桁数
232 11 3
---
条件は >=10(10以上) で <>8(桁数はNot 8桁)
↑設定・実行結果イメージ
パターン３ Q_YUBIN_1to9
カウント数が１０以下（１〜９）郵便番号が何桁であろうが
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
郵便番号 郵便番号のカウント 桁数
194-0012 1 8
228 1 3
700-0941 1 8
---
条件は <10 (10以下) で (桁数の条件は無し)
↑設定・実行結果イメージ
今回は、このクエリーを元に、データを出力してみたいと思います。
↑エクセルへのクエリー結果出力イメージ
↑データセットのイメージ
プログラムを書くと、少し複雑だけど、
（まだまだ、改良の余地アリダケド）
nRCNT = nRCNT + 1 '処理レコード数を増やす
If nRCNT > 10 Then '処理したレコードが10を越えた(次の列)
nXLINE = nXLINE + 3 '次の列へカウンタを移動
If nXLINE > 9 Then '列が越えた？
nXLINE = 1 '1列目（Ａ列）に戻す
nYLINE = nYLINE + 2 '空白行にしたいのでセット位置を＋２する
Else
nYLINE = nYLINE - 10 '列が変わったので行カウンタをマイナスする
End If
'見出しの表示
objEXCEL.Cells(nYLINE, nXLINE) = "郵便番号"
objEXCEL.Cells(nYLINE, nXLINE + 1) = "件数"
nYLINE = nYLINE + 1 '見出し表示分行数が増えます
nRCNT = 1 '見出し表示後は１レコード目だよ
Else '
nYLINE = nYLINE + 1 '次の行へセット位置を移動
End If
で、なんとか、
セット位置を移動しながらデータをセルにセットすることが出来きました。