アクセスからエクセルテンプレートを複製して改名

質問

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

アクセスのクエリを
エクセルのテンプレートへ出力する際、
セルの位置を指定してフィールド値を出力したいです。

また、複製したファイル名に
そのフィールド値を使って「名前を付けて保存」としたいのですが
知識不足のため、ご教示いただけないでしょうか。

クエリ名：qry_expt
（クエリの）フィールド名：顧客番号・氏名・住所・電話番号・年齢・登録日・削除日・利用日・利用回数・利用内容・ナド・・・

エクセルテンプレート名：報告書
出力先セルと出力フィールド：B10（顧客番号）・E10（氏名）・B13（住所）・B14（電話番号）・B20（利用日）・・
改名したいファイル名：報告書_[氏名]_[利用日]

過不足ありましたら、追記させていただきます。
是非、よろしくお願い致します。

回答No.3

piroin654 · ベストアンサー

>Microsoft DAO XXXObject Libraryですが、既にあるモジュールで使われています。
>と出てしまうので、設定しなくて大丈夫ということでしょうか？

チェックが入っていれば設定は不要です。

>Dim objExcel As Excel.Application
>Dim wkb As Excel.Workbook
>でもエラーで止まってしまうので、コメントアウトしてテスト作動してみましたが、大丈夫でしょうか？

>フォームのtxt_Pathというテキストボックスに作成するのですが、
>どのように修正するとよろしいでしょうか？

これらについてはまとめて書き換えましたので以下のコードで確認してください。

Private Sub コマンド2_Click()
　　Dim db As DAO.Database
　　Dim rs As DAO.Recordset
　　Dim objExcel As Object
　　Dim wkb As Object
　　Dim i As Long
　　Dim strFileName As String
　　Dim strName As String
　　Dim strDate As String
　　Dim objFSO As Object
　　Dim strPath As Long

　　'コピー先のフォルダの確認など。
　　If IsNull(Me!txt_Path) Then
　　　　MsgBox ("コピー先のパスが入力されていません")
　　　　Exit Sub
　　End If

　　If Dir(Me!txt_Path, vbDirectory) = "" Then
　　　　MsgBox ("フォルダがみつかりません.パスを正確に設定してください。")
　　　　Exit Sub
　　End If

　　If Not GetAttr(Me!txt_Path) = vbDirectory Then
　　　　MsgBox ("コピー先が不正です。コピー先のフォルダのパスを確認してください。")
　　　　Exit Sub
　　Else
　　　　If MsgBox(Me!txt_Path & "にコピーしてよろしいですか？", vbYesNo) = vbNo Then
　　　　　　MsgBox ("コピーを取り止めます。")
　　　　　　Exit Sub
　　　　End If
　　End If

　　Set objExcel = CreateObject("Excel.Application")
　　Set wkb = objExcel.Workbooks.Open(Filename:=Me!txt_Path & "\報告書.xls")

　　Set db = CurrentDb
　　Set rs = db.OpenRecordset("qry_expt")
　　If rs.RecordCount > 0 Then
　　　　Do Until rs.EOF
　　　　　　For i = 0 To rs.Fields.Count - 1
　　　　　　　　If rs.Fields(i).Name = "顧客番号" Then
　　　　　　　　　　wkb.Sheets("Sheet1").Range("B10") = rs.Fields(i).Value
　　　　　　　　End If

　　　　　　　　If rs.Fields(i).Name = "氏名" Then
　　　　　　　　　　'ファイル名用にデータの取り出し
　　　　　　　　　　strName = rs.Fields(i).Value
　　　　　　　　　　wkb.Sheets("Sheet1").Range("E10") = rs.Fields(i).Value
　　　　　　　　End If

　　　　　　　　If rs.Fields(i).Name = "住所" Then
　　　　　　　　　　wkb.Sheets("Sheet1").Range("B13") = rs.Fields(i).Value
　　　　　　　　End If

　　　　　　　　If rs.Fields(i).Name = "電話番号" Then
　　　　　　　　　　wkb.Sheets("Sheet1").Range("B14") = rs.Fields(i).Value
　　　　　　　　End If

　　　　　　　　If rs.Fields(i).Name = "利用日" Then
　　　　　　　　　　'ファイル名用にデータの取り出し
　　　　　　　　　　'"yyyy/mm/dd"ままだとエラーを起こすので"yyyy-mm-dd"のようにフォーマット。
　　　　　　　　　　strDate = Format(rs.Fields(i).Value, "yyyy-mm-dd")
　　　　　　　　　　wkb.Sheets("Sheet1").Range("B20") = rs.Fields(i).Value
　　　　　　　　End If

　　　　　　　　'以下必要に応じてデータを設定してください。

　　　　　　Next i
　　　　rs.MoveNext
　　　　Loop
　　strFileName = "報告書_[" & strName & "]_[" & strDate & "]"
　　'同じ名前のファイルがあるか確認。あればコピーを中止。
　　If Dir(Me!txt_Path & "\" & strFileName & ".xls") <> "" Then
　　　　MsgBox "同じ名前のファイルが指定先のフォルダに存在するのでコピーを中断します。"
　　　　Exit Sub
　　End If

　　'テンプレートを保存してデータを確定
　　wkb.Save
　　objExcel.DisplayAlerts = False
　　'ファイルのコピー作業
　　Set objFSO = CreateObject("Scripting.FileSystemObject")
　　objFSO.CopyFile CurrentProject.Path & "\報告書.xls", Me!txt_Path & "\" & strFileName & ".xls"
　　objExcel.DisplayAlerts = True

　　Else
　　　　MsgBox ("レコードがありません")
　　　　Exit Sub
　　End If

　　wkb.Close: Set wkb = Nothing
　　objExcel.Quit
　　Set objExcel = Nothing
　　rs.Close: Set rs = Nothing
　　db.Close: Set db = Nothing
　　Set objFSO = Nothing
End Sub

分からないところ、エラーの発生などがありましたら補足してください。

回答No.4

piroin654

すみません。すべて訂正したつもりが一つ残っていました。

objFSO.CopyFile CurrentProject.Path & "\報告書.xls", Me!txt_Path & "\" & strFileName & ".xls"

を

objFSO.CopyFile Me!txt_Path & "\" & "報告書.xls", Me!txt_Path & "\" & strFileName & ".xls"

に訂正してください。一応、テンプレートとコピーするファイルは
同じフォルダとしています。

回答No.2

piroin654

No1です。
忘れていましたが、Excelのファイルの拡張子はxlsにしていますが、
違っていたら訂正しておいてください。何ヶ所かあります。

回答No.1

piroin654

質問の内容から、クエリで取り出されるレコードは一つとします。
違っていたら補足してください。

なお、DAOを使いますのでコード表のツール、参照設定から
DAOを参照するために
　　　Microsoft DAO XXXObject Library
にチェックが入っているか確認してください。XXXは数値でそれぞれの
Accessのバージョンによって違いますが。これにチェックが入っていないと
エラーが生じます。チェックをいれたらOKボタンを押してください。

それから、Excelも使用しますので同様に参照設定で
　　　Microsoft Excel XXXObject Library
にチェックを入れてください。

なお、日付については"yyyy/mm/dd"のようにクエリに表示されている
ものとしています。違っていたら補足してください。

Sub test()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim objExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim i As Long
Dim strFileName As String
Dim strName As String
Dim strDate As String
Dim objFSO As Object

Set objExcel = CreateObject("Excel.Application")
Set wkb = objExcel.Workbooks.Open(Filename:=CurrentProject.Path & "\報告書.xls")

Set db = CurrentDb
Set rs = db.OpenRecordset("qry_expt")
If rs.RecordCount > 0 Then
Do Until rs.EOF
For i = 0 To rs.Fields.Count - 1

If rs.Fields(i).Name = "顧客番号" Then
wkb.Sheets("Sheet1").Range("B10") = rs.Fields(i).Value
End If

If rs.Fields(i).Name = "氏名" Then
'ファイル名用にデータの取り出し
strName = rs.Fields(i).Value
wkb.Sheets("Sheet1").Range("E10") = rs.Fields(i).Value
End If

If rs.Fields(i).Name = "住所" Then
wkb.Sheets("Sheet1").Range("B13") = rs.Fields(i).Value
End If

If rs.Fields(i).Name = "電話番号" Then
wkb.Sheets("Sheet1").Range("B14") = rs.Fields(i).Value
End If

If rs.Fields(i).Name = "利用日" Then
'ファイル名用にデータの取り出し
'"yyyy/mm/dd"ままだとファイル名の設定でエラーを起こすので"yyyy-mm-dd"のようにフォーマット
strDate = Format(rs.Fields(i).Value, "yyyy-mm-dd")
wkb.Sheets("Sheet1").Range("B20") = rs.Fields(i).Value
End If

'以下必要に応じてデータを設定してください。

Next i
rs.MoveNext
Loop

'保存してデータを確定
wkb.Save
objExcel.DisplayAlerts = False
'ファイルのコピー作業
strFileName = "報告書_[" & strName & "]_[" & strDate & "]"
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.CopyFile CurrentProject.Path & "\報告書.xls", CurrentProject.Path & "\" & strFileName & ".xls"
objExcel.DisplayAlerts = True

Else
MsgBox ("レコードがありません")
Exit Sub
End If

wkb.Close: Set wkb = Nothing
objExcel.Quit
Set objExcel = Nothing
rs.Close: Set rs = Nothing
db.Close: Set db = Nothing
Set objFSO = Nothing
End Sub

わからないところがあれば補足してください。

補足

初歩的な質問ですみません。
Microsoft DAO XXXObject Libraryですが、既にあるモジュールで使われています。と出てしまうので、設定しなくて大丈夫ということでしょうか？
また、それに関連するのか・・
Dim objExcel As Excel.Application
Dim wkb As Excel.Workbook
でもエラーで止まってしまうので、コメントアウトしてテスト作動してみましたが、大丈夫でしょうか？

また、
エクセルのテンプレーとファイルがアクセスとは別のパスにある場合は、Set wkb = FileName:=CurrentProject.Path部分を修正すれば良いのでしょうか？
ちなみに、フォームのtxt_Pathというテキストボックスに作成するのですが、どのように修正するとよろしいでしょうか？

あれもこれもで申し訳ありませんが、よろしくお願いします。