Access VBAでシートとセルを指定してエクスポート

2457 ワード
AccessVBA access access テキストリンク

やりたいこと

AccessでExcelの同一のシートへ追記したい。（通常のエクスポートでシート単位でデータが作成されるので）
こんなテーブルがあったとします。↓　ここから年齢別にクエリをかけて同じシートへ追記していくようにします。

Excelのシート、セルを指定して追記するコード

呼出側で指定されたクエリを読み込んで、データを追記していきます。ポイントはエクセルの最終行の取得の部分です。
introw = .cells(.rows.Count, 1).End(-4162).row + 1
[終端セルを参照する(Endプロパティ)]などで検索するとでてきます。エクセルVBAならxlupで良いのですが、Accessはそんなことはわからないので明示してあげます。また、追記するのは最終行の次の行になるので＋１とします。

Sub Excelのセルを指定して貼りつけ(qname As String)
Dim db As Database
Dim rs As Recordset

Dim xpath As String
xpath = CurrentProject.Path

Dim introw,col as Integer
Dim xls As Object

Set db = CurrentDb
'呼出側のクエリ名を取得
Set rs = db.OpenRecordset(qname)
'Excelの生成
Set xls = CreateObject("Excel.Application")

xls.workbooks.Open (xpath & "\test.xls")
With xls.sheets("年齢別")
'見出し行をコピー
introw = 1
For col = 1 To rs.Fields.Count
'MsgBox rs.Fields(col - 1).Name
.cells(introw, col).Value = rs.Fields(col - 1).Name
'MsgBox .cells(row, col).Value
Next col

'見出し行以降をexcelの最終行に追記
introw = .cells(.rows.Count, 1).End(-4162).row + 1
Do Until rs.EOF
    For col = 1 To rs.Fields.Count
    .cells(introw, col).Value = rs.Fields(col - 1)
    Next col
    introw = introw + 1
    rs.MoveNext
Loop
rs.close
End With

xls.workbooks("test.xls").Save
xls.workbooks("test.xls").Close
Set xls = Nothing
End Sub

次にこのサブルーチンを呼び出すコードを記述します。
クエリの条件を変更しながらデータを抽出して、先述のサブルーチンを実行していきます。

Sub クエリ実行()
Dim sql As String
Dim db As Database
Set db = CurrentDb
Dim myq As QueryDef

Dim age(2) As String
age(0) = 25
age(1) = 30
age(2) = 45

Dim i As Long

For i = 0 To 2
sql = "select * from T_顧客管理 where T_顧客管理.年齢=" & age(i) & ";"
Set myq = db.CreateQueryDef("Q_顧客管理", sql)
Call Excelのセルを指定して貼りつけ("Q_顧客管理")
Application.CurrentDb.QueryDefs.Delete "Q_顧客管理"
Next

db.Close
Set db = Nothing
End Sub

クエリの実行結果が年齢順に追記されています。参考になれば幸いです。