こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

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

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

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

投稿日時 - 2018-03-23 10:02:43

QNo.9480840

困ってます

質問者が選んだベストアンサー

>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



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

投稿日時 - 2018-03-26 12:59:41

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.4

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

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



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

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

投稿日時 - 2018-03-26 13:38:08

ANo.2

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

投稿日時 - 2018-03-24 08:46:18

ANo.1

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

なお、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



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

投稿日時 - 2018-03-24 08:40:47

補足

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

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

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

投稿日時 - 2018-03-26 10:09:26

あなたにオススメの質問