アクセスからエクセルのテンプレートへの出力

質問

お世話になっております。

アクセス（クエリ）から
テンプレートファイル（エクセル）へ
ユーザー単位で出力するには
どのようにすれば良いでしょうか？

QRY_出力：
ユーザー名｜ユーザーID｜商品｜単価｜数量｜日付
という表示クエリがあり、
このクエリから　ユーザー名毎（もしくはユーザーID毎）に
テンプレートファイル（エクセル）の「出力Sheet」へ出力した上で、
[ユーザー名]_出力日.xlsx　という名前で別名保存したいです。
※商品×1のユーザーは1レコード
　商品×2のユーザーは2レコード・・・の出力のイメージです。

初心者につき、つたない説明かもしれませんが、
ご教示のほどよろしくお願い致します。

回答No.1

piroin654 · ベストアンサー

テンプレートファイルのあるフォルダ名を「出力用」、
ファイルのコピー先フォルダ名を「保存用」としています。
実際にあわせて変更してください。
保存するときにユーザーIDとユーザー名のどちらを使用するかは
一概に言えませんが、わかりやすいのはユーザー名かもしれませんが、
同姓同名が存在するともかぎらないので一応、一意性のある
ユーザーIDで保存するようにしています。ユーザー名を使う場合は、
コード中のstrFileNameを差し替えればいいようになっています。
コード中にコメントしてあります。
なお、strSQL文はデータ量が多い場合はクエリとして保存して
使ってもいいかもしれません。
一度に保存するファイル数が多くなるとそれなりに時間がかかります。

Sub test()
　　Dim db As DAO.Database
　　Dim rs1 As DAO.Recordset
　　Dim rs2 As DAO.Recordset
　　Dim strSQL As String
　　Dim objExcel As Object
　　Dim objWorkBook As Object
　　Dim objSheet As Object
　　Dim objFSO As Object
　　Dim strTemplatePath As String
　　Dim strStorePath As String
　　Dim i As Long
　　Dim j As Long
　　Dim m As Long
　　Dim n As Long
　　Dim varUserID As Variant
　　Dim varUserName As Variant
　　Dim strDate As String
　　Dim strFileName As String

　　'ユーザーIDまたは、ユーザーIDとユーザー名の両方の名寄せ。以下のSQL文のどちらかを使用
　　'strSQL = "SELECT ユーザーID FROM QRY_出力 GROUP BY ユーザーID ORDER BY ユーザーID;"
　　strSQL = "SELECT ユーザー名, ユーザーID FROM QRY_出力 GROUP BY ユーザー名, ユーザーID ORDER BY ユーザーID;"
　　'テンプレートファイルのアドレス
　　strTemplatePath = "C:\Users\hoge\出力用" & "\テンプレート.xlsx"
　　'保存用フォルダのアドレス
　　strStorePath = "C:\Users\hogehoge\保存用"
　　'ファイル名でのエラー回避のために日付の表示変更
　　strDate = Format(Date, "yyyy-mm-dd")

　　Set db = CurrentDb
　　Set rs1 = db.OpenRecordset(strSQL)
　　Set rs2 = db.OpenRecordset("QRY_出力")
　　Set objExcel = CreateObject("Excel.Application")
　　Set objWorkBook = objExcel.Workbooks.Open(Filename:=strTemplatePath)
　　Set objSheet = objWorkBook.WorkSheets("出力Sheet")

　　If rs1.RecordCount > 0 Then
　　　　rs1.MoveFirst
　　　　Do Until rs1.EOF
　　　　'一応、ユーザーIDとユーザー名の両方を取得。
　　　　varUserID = rs1!ユーザーID
　　　　varUserName = rs1!ユーザー名
　　　　'ヘッダを入れるのでデータの書き込みは2行目からなのでmの初期値を2に設定
　　　　m = 2
　　　　'ユーザー名を使う場合は下のstrFileName。
　　　　strFileName = "[" & varUserID & "]" & "_" & strDate
　　　　'strFileName = "[" & varUserName & "]" & "_" & strDate
　　　　'同じファイル名のものが存在しないか確認。
　　　　If Len(Dir(strStorePath & "\" & strFileName & ".xlsx")) = 0 Then
　　　　　　If rs2.RecordCount > 0 Then
　　　　　　　　'ヘッダの書き込み。
　　　　　　　　For i = 1 To rs2.Fields.Count
　　　　　　　　　　objSheet.Cells(1, i) = rs2.Fields(i - 1).Name
　　　　　　　　Next i
　　　　　　　　'データの検索と書き込み。
　　　　　　　　rs2.MoveFirst
　　　　　　　　Do Until rs2.EOF
　　　　　　　　　　If rs2!ユーザーID = varUserID Then
　　　　　　　　　　　　For n = 1 To rs2.Fields.Count
　　　　　　　　　　　　　　objSheet.Cells(m, n) = rs2.Fields(n - 1).Value
　　　　　　　　　　　　Next n
　　　　　　　　　　　　'次の行の設定。
　　　　　　　　　　　　m = m + 1
　　　　　　　　　　End If
　　　　　　　　rs2.MoveNext
　　　　　　　　Loop

　　　　　　　　objExcel.DisplayAlerts = False
　　　　　　　　'テンプレートファイルのデータの確定。
　　　　　　　　objWorkBook.Save

　　　　　　　　'ファイルのコピー。
　　　　　　　　Set objFSO = CreateObject("Scripting.FileSystemObject")
　　　　　　　　　　objFSO.CopyFile strTemplatePath, strStorePath & "\" & strFileName & ".xlsx"
　　　　　　　　objExcel.DisplayAlerts = True
　　　　　　End If
　　　　　　objExcel.DisplayAlerts = False
　　　　　　'出力Sheetの初期化
　　　　　　objSheet.Cells.Clear
　　　　　　'テンプレートファイルの変更確定。
　　　　　　objWorkBook.Save
　　　　　　objExcel.DisplayAlerts = True
　　　　End If
　　　　rs1.MoveNext
　　　　Loop
　　End If

　　rs1.Close: Set rs1 = Nothing
　　rs2.Close: Set rs2 = Nothing
　　db.Close: Set db = Nothing

　　objWorkBook.Close: Set objWorkBook = Nothing
　　objExcel.Quit
　　Set objExcel = Nothing
　　Set objFSO = Nothing
End Sub

何かあれば補足してください。

お礼

確認が遅くなり、お礼も遅れましたこと、申し訳ございません。
ご丁寧なご教示、ありがとうございます。

補足

初心者につき 追加で教えてください！
'テンプレートファイルの変更確定。
objWorkBook.Save
のところで、デバックしてしまいます。
ファイルはちゃんと作成されているのですが・・・？

回答No.3

piroin654

（１）
何かメッセージが出ますか？

（２）
ファイルは複数必要ならばすべて作成されますか？

（３）
一度、以下のようにしてみるとどうなりますか？

　　　 'テンプレートファイルの変更確定。
　　　On Error Resume Next
　　　objWorkBook.Save
　　　On Error Resume 0

お礼

お礼が遅くなってしまい、大変申し訳ございません。
エラー処理にMsgBox Err.Descriptionを入れて調べて、対応することができました。
お騒がせしました。また、親切なご教示、とても参考になりました。本当にありがとございます。

回答No.2

piroin654

訂正です。

　　'ファイルのコピー。

のところで、、

　　Set objFSO = CreateObject("Scripting.FileSystemObject")

を、

　　Set db = CurrentDb
　　Set rs1 = db.OpenRecordset(strSQL)
　　Set rs2 = db.OpenRecordset("QRY_出力")
　　Set objExcel = CreateObject("Excel.Application")
　　Set objWorkBook = objExcel.Workbooks.Open(Filename:=strTemplatePath)
　　Set objSheet = objWorkBook.WorkSheets("出力Sheet")
　　Set objFSO = CreateObject("Scripting.FileSystemObject")

のように移動してください。オブジェクトの設定を何度もすることに
なっていました。ミスでした。