お世話になります。
アクセスは10年程度使用していますが、VBAは難易度が高い物はまだできません。
アクセスで見積書を作成してフォーム→レポート→PDF出力の流れで完成しましたが、依頼者からエクセルに出力できるようにしてもらいたいとの要望があり、ネットで調べていますが該当する物が見つかりません。
見積書のクエリは明細1（表紙）・明細2・明細3となっており、全て明細IDで連動しています。
DAOで3つのレコードセットをそれぞれエクスポートをしようとしても違うようです。
DoCmd.TransferSpreadsheetで3つのクエリをエクスポートすると3つ目のデータはエクスポートされますが
、前の2つは消えてしまいます。
DAOの考え方が未熟なため、3つのクエリのIDでフィルターを掛けて、エクセルへエクスポートするコードご教示ください。
お手数を掛けますが、よろしくお願いします。
回答するには、
見積書のクエリのそれぞれのフィールド構成、
エクセルへ出力する場合のレイアウト、
の情報が必要かと思います。
できれば、それぞれのクエリのデータ例、
それをエクセルに出力したときのデータレイアウト、
があればより回答しやすいです。
お世話様です。早速の書き込みを有難うございます。
クエリはテーブルを元に作成しており、それぞれT_明細1、T_明細2、T_明細3のテーブルとなっていて、3つのテーブルは明細NOフィールドをオートナンバーとして、テキストフィールドと数値や計算式のフィールドは数値型となっています。
テーブルをそのままクエリにしていますが、基本となるT_見積物件情報の見積りNOをオートナンバーとして、3つのクエリはQ_明細1、Q_明細2、Q_明細3で、見積りNOと明細NOにテキストと数値フィールドで構成されています。
Q_明細1のみは、T_見積物件情報とT_明細1の2つのテーブルとしています。
最大で3枚の見積書になりますが、フォームで親をT_見積物件情報、子を明細1～3で各フィールドをエクセルのような配置にしており、明細1は約170(7列×24行)フィールド明細2と3は約200(7列×28行)フィールドづつになっています。
T_見積物件情報は殆んどがテキスト型で、物件名・誦所・担当者に日付などが有ります。
Q_明細1・2・3は見積り書のNO・品名・数量・単位・単価・金額・備考（7列）で、T_製品マスタから品名をコンボボックスで選択し、数量を入れると単位・単価・金額が入るようになっています。
エクセルに出力するには上記と同じ形式の帳票で考えていますが、1物件づつの見積り書としてエクスポートするために、フォームの見積りNOでフィルターを掛けて、各クエリのデータをエクセルのシート１・２・３へ1行づつ出力して、それを元にしてもう一つのシートへ見積書として統合するよう、エクセル側でVBAを組んでデータを振り分けたいと考えています。
以上がデータベースの概要ですが、不足が有りましたらご指摘ください。
お手数を掛けますが、ご教示をよろしくお願いします。
エクセルファイルは新規に作成したものにエクスポートするのでしょうか。
それとも既存のテンプレートがあり、そこに出力するということでしょうか。
DoCmd.TransferSpreadsheetで既存のエクセルファイルにエクスポートすると、クエリはそれぞれ別々のシートに出力されると思いますが、そうはならないですか。
まずは、現状のコードを提示してもらえますか。
お世話様です。書き込みを有難うございます。
既存のテンプレートで名前を物件名を入れ込んで保存しようとしていました。（過去にこれは作成しています）
エクスポートはシートを指定して（クエリ毎にシート1・２・３と指定している）いますが、新しく書き込みをするようで、初めのシート1・2は消えて3だけがエクスポートされます。
お世話様です。ネットの記事を読んで作成しましたが、VBA勉強不足のために途中で止まりました。
以下、2つのコードです。ご教示をよろしくお願いします。
■DAOでエクスポートをしようとした
Private Sub コマンド53_Click()
Dim SQL As String
Dim dbs As DAO.Database
Dim qdf1 As DAO.QueryDef
Dim qdf2 As DAO.QueryDef
Dim qdf3 As DAO.QueryDef
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim rst3 As DAO.Recordset
Dim xls As Object
Dim strSaveBookPath As String
'テンプレートの保存先フォルダ
Const cstrTemplateDir As String = "\SV30**\metal2*課\HDD\リフォーム見積りDB\見積書\"
Const cstrTemplateBook As String = "RF見積書.xlsx" 'テンプレートのファイル名
Const cstrSaveBookDir As String = "\SV30\metal2***課\HDD\リフォーム見積りDB\見積書\" 'データが代入されたファイルの保存先フォルダ
Set dbs = CurrentDb 'データ元のクエリを開く
Set qdf1 = dbs.QueryDefs("Q_見積明細1_P") 'クエリのオブジェクトを取得します
With qdf1
'クエリのオブジェクトに対して設定を行います。”抽出する○○ID”などがパラメータ名です
.Parameters("見積りNo").Value = Forms!F_見積!見積りNo
Set rst1 = .OpenRecordset '設定後のクエリオブジェクトを元にRecordsetを開きます
End With
Set xls = CreateObject("Excel.Application") 'Excelオブジェクトを生成
With xls
.ScreenUpdating = False '画面の再描画を抑止
.Workbooks.Open cstrTemplateDir & cstrTemplateBook 'テンプレートファイルを開く
.Workbooks(cstrTemplateBook).WorkSheets("Sheet1").Copy 'ワークシートをコピー
.DisplayAlerts = False 'テンプレートファイルを閉じる
.Workbooks(cstrTemplateBook).Save
.Workbooks(cstrTemplateBook).Close
.DisplayAlerts = True
.Cells(2, 1).CopyFromRecordset rst1
Set qdf2 = dbs.QueryDefs("Q_明細2_R")
With qdf2
.Parameters("見積りNO") = Forms!F_見積!見積りNo
Set rst2 = .OpenRecordset
End With
Set xls = CreateObject("Excel.Application")
With xls
■次に続きます
■続きです
.ScreenUpdating = False
.Workbooks.Open cstrTemplateDir & cstrTemplateBook
.Workbooks(cstrTemplateBook).WorkSheets("Sheet2").Copy
.DisplayAlerts = False
.Workbooks(cstrTemplateBook).Save
.Workbooks(cstrTemplateBook).Close
.DisplayAlerts = True
.Cells(2, 1).CopyFromRecordset rst2
Set qdf3 = dbs.QueryDefs("Q_明細3_R")
With qdf3
.Parameters("見積りNO") = Forms!F見積!見積りNo
Set rst3 = .OpenRecordset
End With
Set xls = CreateObject("Excel.Application")
With xls
.ScreenUpdating = False
.Workbooks.Open cstrTemplateDir & cstrTemplateBook
.Workbooks(cstrTemplateBook).WorkSheets("Sheet3").Copy
.DisplayAlerts = False
.Workbooks(cstrTemplateBook).Save
.Workbooks(cstrTemplateBook).Close
.DisplayAlerts = True
.Cells(2, 1).CopyFromRecordset rst3
rst1.Close
rst2.Close
rst3.Close
'保存するファイル名のフルパスを組み立て
strSaveBookPath = cstrSaveBookDir & "見積書" & Format$(Forms!F_見積!物件名) & ".xlsx"
On Error Resume Next '同名ファイルを強制削除
Kill strSaveBookPath
On Error GoTo 0
.ScreenUpdating = True '画面の再描画を元に戻す
.ActiveWorkbook.SaveAs strSaveBookPath 'データを代入したブックを保存
MsgBox "データを保存しました"
.Quit 'Excelを終了
End With
Set xls = Nothing
End With
End With
End Sub
■DoCmdエクスポートのコードです～シート3のみが保存されてシート１・２は消えてしまいました。
Function エクセルへエクスポート()
Dim strSaveBookPath As String
Dim xls As Object
'テンプレートの保存先フォルダ
Const cstrTemplateDir As String = "\SV30**\metal2*課\HDD\リフォーム見積りDB\見積書\"
'テンプレートのファイル名
Const cstrTemplateBook As String = "RF見積書.xlsx"
'データが代入されたファイルの保存先フォルダ
Const cstrSaveBookDir As String = "\SV30\metal*2****課\HDD\リフォーム見積りDB\見積書\"
On Error GoTo エクセルへエクスポート_Err
'Excelオブジェクトを生成
Set xls = CreateObject("Excel.Application")
With xls
'画面の再描画を抑止
.ScreenUpdating = False
'テンプレートファイルを開く
.Workbooks.Open cstrTemplateDir & cstrTemplateBook
On Error GoTo エクセルへエクスポート_Err
DoCmd.TransferSpreadsheet acExport, 10, "Q_見積明細1_P", "\SV30**\metal2*課\HDD\リフォーム見積りDB\見積書.xlsx", True, "Sheet1"
DoCmd.TransferSpreadsheet acExport, 10, "Q_明細2_R", "\SV30\metal*2*課\HDD\リフォーム見積りDB\見積書.xlsx", True, "Sheet2"
DoCmd.TransferSpreadsheet acExport, 10, "Q_明細3_R", "\SV30\metal*2****課\HDD\リフォーム見積りDB\見積書.xlsx", True, "Sheet3"
'保存するファイル名のフルパスを組み立て
.strSaveBookPath = cstrSaveBookDir & "見積書_" & Format$(Forms!F_見積!物件名) & ".xlsx"
'同名ファイルを強制削除
On Error Resume Next
Kill strSaveBookPath
On Error GoTo 0
'画面の再描画を元に戻す
.ScreenUpdating = True
'データを代入したブックを保存
.ActiveWorkbook.SaveAs strSaveBookPath
MsgBox "データを保存しました"
'Excelを終了
.Quit
End With
Set xls = Nothing
エクセルへエクスポート_Exit:
Exit Function
エクセルへエクスポート_Err:
MsgBox Error$
Resume エクセルへエクスポート_Exit
End Function
【追記】
DoCmd.Trnasferは見積りNOでフィルターが掛けられず、全てのデータが出てくるので、これにフィルターが掛けられればこちらのほうが簡単です。
よろしくお願いします。
質問が混在してますが、とりあえず、最初の質問の
についてのみ。
該当するコードは下記の部分だと思いますが、
エクスボート先のファイルパスがそれぞれ異なりますが、これは、コードを転記したときに転記ミスですか。
実際のパス名は３つとも同じになってますか。
お世話様です。書き込みを有難うございます。
転記したときの誤りの様で、実際のファイルパスは全て同じです。
よろしくお願いします。
このように想定通りに動作しない場合、原因を探るには、なるべく単純化したコードで一つずつ、動作を確認していき、とこで異常が発生するかを特定するというようなデバッグ作業をするようにします。
その場合、エラートラップのコードはコメントアウトしておきます。そうしないと、エラーが出てもどこででているか特定できないので。
とりあえず下記のコードを実行して、見積書.xlsxファイルを開いて、Sheet1, Sheet2, Sheet3 にそれぞれのクエリのデータが出力されているか、確認してください。
お世話様です。お手数を掛けます。
ご教示を有難うございます。
上記のテストコードで動かすと、エクセルに元々あるシート１～３には書き込みがされず、同じブック内に新たにシート11/21/31と言うシートを作って、その３つのシートに3つのクエリのデータが一つづつ書込まれます。
これは既にテストをしておりましたが、見積りが多くなって毎回すべてのデータが書込まれると大変なため、このコードに指定した見積りNOのデータのみをエクスポートするコードが無いか調べましたが、ヒントとなるコードでエクスポートするとシート3のみだけ指定見積りNOのデータがエクスポートされましたが、シート1と2は残りませんでした。これ以外は見つからないためにDAOでエクスポートする方策を検討していました。
もし、テストコードに指定する見積りNOのデータのみエクスポートするコードが有ればご教示ください。
様々にお世話になりますが、よろしくお願いします。
最初の質問とは異なる現象ですね。当方で実験した限りでは、すでに同名シートがある場合は上書きされました。
どちらにしても、DoCmd.TransferSpreadsheetを使うなら、設計としては下記のようになるかと思います。
テンプレートには、Sheet1、Sheet２、Sheet３ は持たせない。
テンプレートを複製して、そのファイルにクエリをエクスポートする。
テンプレートファイル側で、エクスポートされたシートからテンプレートシートにデータを転記する(Access VBAでエクセルファイルを操作する方法でもOK)。
エクスポートするクエリはパラメータークエリにして、パラメータはフォームのテキストボックスを参照するようにして、テキストボックスに条件値を入力してから、DoCmd.TransferSpreadsheetを実行すれば、条件値で絞り込まれたデータがエクスポートされます。
お世話様です。ご教示を有難うございました。
VBAで多少不詳の所が有りますが、トライしてみます。
種々、大変に有難うございました。
お世話になりました。取り急ぎ以下のコードでパラメータクエリを使用することなく、パラメータのポップアップが出てこなくて、フィルターの掛かったデータをエクセルのシート1/2/3にエクスポートすることが出来ました。大変に有難う御座いました。
Dim strQryName As String
Dim strSQL As String
Dim FileName As String
strQryName = "Q_明細1" '←お好みの名前にする
strSQL = "SELECT * FROM Q_見積明細1_P WHERE T_見積物件情報.見積りNo=" & Forms!F_見積_1!見積りNo
On Error Resume Next
CurrentDb.CreateQueryDef strQryName, strSQL
'↑でエラーなら存在済みとみなし↓SQL変更処理を行う
If Err <> 0 Then
CurrentDb.QueryDefs(strQryName).SQL = strSQL
On Error GoTo 0
End If
CurrentDb.QueryDefs.Refresh
RefreshDatabaseWindow
FileName = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "見積書.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, strQryName, FileName, True, "明細1"
シート2/3は、シート1とほぼ同様のコードです。