Access2002によるエクセルへの出力

質問

現在、Accessで案件整理のDBを作成しております。

job-list.xlsというエクセルファイルの所定のシートに
クエリであるQ_ジョブリストの表の値を一行ずつ差し込みたいと思っています。

そこで、下記の通りVBにてプログラムを組みましたが
エクセルシートのB5から始まる一行目にクエリ表の一行目が入るのみで
全データを差し込みできません。

下記のプログラムをベースにB5以降もクエリ表の1行目以降の値が差し込みされるようにしたいと思っております。

どなたかご教授いただけますでしょうか。
よろしくお願いいたします。

Private Sub コマンド103_Click()
Me.Requery
myXLS = CurrentProject.Path & "\job-list.xls"

Set myEXE = CreateObject("Excel.Application")
myEXE.Visible = True
Set myBK = myEXE.Workbooks.Open(myXLS)
Set myRS = Application _
.CurrentProject _
.Connection _
.Execute("SELECT * FROM Q_ジョブリスト")
myCNT = 0

myBK.sheets("新規ジョブ").range("B5") = myRS("ジョブNo")
myBK.sheets("新規ジョブ").range("C5") = myRS("顧客")
myBK.sheets("新規ジョブ").range("D5") = myRS("案件名")
myBK.sheets("新規ジョブ").range("E5") = myRS("制作カテゴリ")
myBK.sheets("新規ジョブ").range("F5") = myRS("発生日")
myBK.sheets("新規ジョブ").range("G5") = myRS("依頼日")

myBK.sheets("新規ジョブ").range("I5") = myRS("納品日")
myBK.sheets("新規ジョブ").range("J5") = myRS("価格")
myBK.sheets("新規ジョブ").range("K5") = myRS("外注費_合計")
myBK.sheets("新規ジョブ").range("L5") = myRS("請求日")
myBK.sheets("新規ジョブ").range("M1") = myRS("入金日")
myBK.sheets("新規ジョブ").range("N1") = myRS("状況")
myBK.sheets("新規ジョブ").Copy
myCNT = myCNT + 1

End Sub

回答No.4

redfox63

dim oSheet as Object
if MyBK is nothing then
　　MsgBox "MyBKの取得に失敗しています"
end if
Set oSheet = myBK.Sheets("新規ジョブ")
if oSheet is nothing then
　　MsgBox "新規ジョブシートの取得に失敗しています"
end if
set oDst = oSheet.Range("A1")
としてみてはいかがでしょう

どのオブジェクトが取得できていないのかを明確にしましょう

WorkBOOKなのかシートなのか

補足

大変ご無沙汰しております。

その後も引き続き取り組んでおりまして、今回は頂いた方法から若干趣向を変えて下記の通りソースを組んでみました。

動作としては、Forループを使って一行目へ転記後に次の行へと転記されるようになったのですが、今回の問題としましてはクエリテーブルの一行目しか転記されないことです。
クエリの1行目が転記されたら2行目が転記されるようにするにはどのような方法がありますでしょうか？

長々のお付き合いでお手数をお掛けいたしますがご教授のほどよろしくお願いいたします。

以下、ソース

Private Sub コマンド103_Click()
Me.Requery
myXLS = CurrentProject.Path & "\job-list.xls"

Set myEXE = CreateObject("Excel.Application")
myEXE.Visible = True
Set myBK = myEXE.Workbooks.Open(myXLS)
Dim i As Integer

For i = 5 To 10

Set myRS = Application _
.CurrentProject _
.Connection _
.Execute("SELECT * FROM Q_ジョブリスト")

myBK.sheets("新規ジョブ").Cells(i, 2) = myRS("ジョブNo")
myBK.sheets("新規ジョブ").Cells(i, 3) = myRS("顧客")
myBK.sheets("新規ジョブ").Cells(i, 4) = myRS("案件名")
myBK.sheets("新規ジョブ").Cells(i, 5) = myRS("制作カテゴリ")
myBK.sheets("新規ジョブ").Cells(i, 6) = myRS("発生日")
myBK.sheets("新規ジョブ").Cells(i, 7) = myRS("依頼日")
myBK.sheets("新規ジョブ").Cells(i, 9) = myRS("納品日")
myBK.sheets("新規ジョブ").Cells(i, 10) = myRS("価格")
myBK.sheets("新規ジョブ").Cells(i, 11) = myRS("外注費_合計")
myBK.sheets("新規ジョブ").Cells(i, 12) = myRS("請求日")
myBK.sheets("新規ジョブ").Cells(i, 13) = myRS("入金日")
myBK.sheets("新規ジョブ").Cells(i, 14) = myRS("状況")

Next i

End Sub

回答No.3

redfox63

Excelへの参照設定を行わないのであれば

Dim oDest as Object
といった具合に宣言しましょう

補足

早速、ご教授頂きまして誠にありがとうございます。

Dim oDest As Object
としてエクセル表は起動したのですが、書き出しはされず
エラーとして424が表示されます。

Set oDest = mkBK.Sheets("新規ジョブ").Range("A1")
で引っかかっているようです。

再三にわたり、大変お手数ですが原因について
ご教授いただけますと誠に幸いです。

どうぞ宜しくお願いいたします。

Private Sub コマンド103_Click()
Me.Requery
myXLS = CurrentProject.Path & "\job-list.xls"

Set myEXE = CreateObject("Excel.Application")
myEXE.Visible = True
Set myBK = myEXE.Workbooks.Open(myXLS)
Set myRS = Application _
.CurrentProject _
.Connection _
.Execute("SELECT * FROM Q_ジョブリスト")
myCNT = 0

Dim oDest As Object
Set oDest = mkBK.Sheets("新規ジョブ").Range("A1")

' 最初のレコードへ移動
rs.MoveFirst
' レコードがなくなるまで繰り返す
Do Until rs.EOF
rDest.Range("B5") = myRS("ジョブNo")
rDest.Range("C5") = myRS("顧客")
rDest.Range("D5") = myRS("案件名")
rDest.Range("E5") = myRS("制作カテゴリ")
rDest.Range("F5") = myRS("発生日")
rDest.Range("G5") = myRS("依頼日")

rDest.Range("I5") = myRS("納品日")
rDest.Range("J5") = myRS("価格")
rDest.Range("K5") = myRS("外注費_合計")
rDest.Range("L5") = myRS("請求日")
rDest.Range("M1") = myRS("入金日")
rDest.Range("N1") = myRS("状況")
' 転記先の更新
Set rDest = rDest.Offset(1, 0)
' 次のレコードへ移動
rs.MoveNext
Loop
rs.Close

End Sub

回答No.2

imogasi

myBK.sheets("新規ジョブ").range("B5") にデータを受け取るのでしょうが、最初のレコードはそれでよくても、アクセスでの第2、第3・・のレコードは
１行ずつ下の行に順次セットしないとならないのでしょう。ですから
B5のように５と固定してはダメで
i=5 'エクセルシートでデータの最初（上）行
ブック・シート指定.Cells(i,"B")=アクセスデータ
・・・他のフィールドへの代入
i=i+1
次の繰り返し（レコード）に移る、
ーー
のように考えること。

お礼

この度は、お礼が遅くなりまして誠に申し訳ございません。
体調不良により、昨日まで入院をしておりまして遅くなりました。

アドバイスを頂きありがとうございます。
参考にさせて頂きます。

回答No.1

redfox63

一枚のシートに クエリーで取ってきたデータをすべて転記したいのでしょうか

そうであればRecordsetをループして処理するように変更しましょう

' 転記対象のRangeオブジェクトを準備します
dim oDest as Range
Set oDest = mkBK.Sheets("新規ジョブ".Range("A1")

' 最初のレコードへ移動
rs.MoveFirst
' レコードがなくなるまで繰り返す
do until rs.EOF
　　rDest.range("B5") = myRS("ジョブNo")
　　rDest.range("C5") = myRS("顧客")
　　rDest.range("D5") = myRS("案件名")
　　rDest.range("E5") = myRS("制作カテゴリ")
　　rDest.range("F5") = myRS("発生日")
　　rDest.range("G5") = myRS("依頼日")

　　rDest.range("I5") = myRS("納品日")
　　rDest.range("J5") = myRS("価格")
　　rDest.range("K5") = myRS("外注費_合計")
　　rDest.range("L5") = myRS("請求日")
　　rDest.range("M1") = myRS("入金日")
　　rDest.range("N1") = myRS("状況")
　　' 転記先の更新
　　set rDest = rDest.Offset( 1, 0 )
　　' 次のレコードへ移動
　　rs.MoveNext
Loop
rs.close

といった具合でしょう
# 字下げに全角スペースを使用しています適宜置換などの修正をしてください

お礼

昨日まで体調不良のため、入院をしておりお返事が遅くなりました。
大変失礼いたしました。

詳細なアドバイス誠にありがとうございます。

頂いたサンプルをこちらで作成したものと組み合わせて下記のように記述いたしましたところ、Dim oDest As Range　のところでユーザー定義型は定義されないとエラーが表示されてしまいます。

出来る限り調べてみましたが、わたしの現在の知識では解決に至らず原因についてご教授頂ければ幸いです。
よろしくお願いいたします。

Private Sub コマンド103_Click()

Me.Requery
myXLS = CurrentProject.Path & "\job-list.xls"

Set myEXE = CreateObject("Excel.Application")
myEXE.Visible = True
Set myBK = myEXE.Workbooks.Open(myXLS)
Set myRS = Application _
.CurrentProject _
.Connection _
.Execute("SELECT * FROM Q_ジョブリスト")
myCNT = 0
' 転記対象のRangeオブジェクトを準備します
Dim oDest As Range
Set oDest = mkBK.Sheets("新規ジョブ").Range("A1")

' 最初のレコードへ移動
rs.MoveFirst
' レコードがなくなるまで繰り返す
Do Until rs.EOF
rDest.Range("B5") = myRS("ジョブNo")
rDest.Range("C5") = myRS("顧客")
rDest.Range("D5") = myRS("案件名")
rDest.Range("E5") = myRS("制作カテゴリ")
rDest.Range("F5") = myRS("発生日")
rDest.Range("G5") = myRS("依頼日")

rDest.Range("I5") = myRS("納品日")
rDest.Range("J5") = myRS("価格")
rDest.Range("K5") = myRS("外注費_合計")
rDest.Range("L5") = myRS("請求日")
rDest.Range("M1") = myRS("入金日")
rDest.Range("N1") = myRS("状況")
' 転記先の更新
Set rDest = rDest.Offset(1, 0)
' 次のレコードへ移動
rs.MoveNext
Loop
rs.Close

End Sub