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

解決済みの質問

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

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

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

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

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

投稿日時 - 2018-05-02 14:19:35

QNo.9494377

困ってます

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

テンプレートファイルのあるフォルダ名を「出力用」、
ファイルのコピー先フォルダ名を「保存用」としています。
実際にあわせて変更してください。
保存するときにユーザー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







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

投稿日時 - 2018-05-04 14:23:34

補足

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

投稿日時 - 2018-05-07 11:40:06

お礼

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

投稿日時 - 2018-05-07 11:40:09

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

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

回答(3)

ANo.3

(1)
何かメッセージが出ますか?

(2)
ファイルは複数必要ならばすべて作成されますか?

(3)
一度、以下のようにしてみるとどうなりますか?


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

投稿日時 - 2018-05-07 13:52:12

お礼

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

投稿日時 - 2018-05-14 12:32:38

ANo.2

訂正です。

  'ファイルのコピー。
        
のところで、、

  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")

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

投稿日時 - 2018-05-07 08:59:58

あなたにオススメの質問