Access (VBA)

Access VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Access 2016)
ExcelのテンプレートにAccessのデータを入力したい
投稿日時: 21/03/12 13:47:01
投稿者: MAXBOX

Accessについて質問です。
AccessのデータをExcelの任意のセルに出力したいのですが処理がうまくいかず困っています。
下記が該当コードです。
 

Public Sub ExcelTemplateSample()

  Dim dbs As Database
  Dim rst As Recordset
  Dim xls As Object
  Dim intRow As Integer
  Dim lngOrderID As Long
  Dim strSaveBookPath As String
  'テンプレートの保存先フォルダ
  Const cstrTemplateDir As String = "C:\name\Desktop\テンプレートファイル\"
  'テンプレートのファイル名
  Const cstrTemplateBook As String = "テンプレート.xlsx"
  'データが代入されたファイルの保存先フォルダ
  Const cstrSaveBookDir As String = "C:\Users\name\Desktop\"

  'データ元のクエリを開く
  Set dbs = CurrentDb
  Set rst = dbs.OpenRecordset("テンプレクエリ")

  'Excelオブジェクトを生成
  Set xls = CreateObject("Excel.Application")
  With xls
    '画面の再描画を抑止
    .ScreenUpdating = False
    'テンプレートファイルを開く
   .Workbooks.Open cstrTemplateDir & cstrTemplateBook
        
    'ワークシートをコピー
    .Workbooks(cstrTemplateBook).Worksheets("原紙").Copy
    'テンプレートファイルを閉じる
    .Workbooks(cstrTemplateBook).Close

    '商品明細の全レコードをループで各セルに代入
    intRow = 10
    Do Until rst.EOF
      .Cells(intRow, 1).Value = rst!番号
      .Cells(intRow, 2).Value = rst!氏名
      .Cells(intRow, 3).Value = rst!種類
      .Cells(intRow, 4).Value = rst!金額
      intRow = intRow + 1
      rst.MoveNext
    Loop
    rst.Close

    '保存するファイル名のフルパスを組み立て
    strSaveBookPath = cstrSaveBookDir & "注文書" & ".xlsx"

    '同名ファイルを強制削除
    On Error Resume Next
    Kill strSaveBookPath
    On Error GoTo 0

    'データを代入したブックを保存
    .ActiveWorkBook.SaveAs strSaveBookPath

    '画面の再描画を元に戻す
    .ScreenUpdating = True
    'Excelを終了
    .Quit

  End With
  Set xls = Nothing

End Sub

 
以上になります。
実行したいことは、 クエリの種別フィールドごとにシート分ける処理を行いたいです。
例えば
 ID 氏名  種別 ・・・
1  ○○  特別会員
2  ○△  通常会員
3  ○✖  通常会員
4  ○□  特別会員
5  ✖□  ビジター
 とあった場合 特別会員のシート、通常会員のシート、ビジターのシートという風に分けたいのです。
同じテンプレートに出力されるデータだけが違います。
このような処理をするにはどうすればよいでしょうか?
教えて頂きたいです。

投稿日時: 21/03/12 13:52:10
投稿者: MAXBOX

投稿者です。
上記で提示したコードを実行すると「実行中」のまま固まってしまいます。
恐らく処理に時間がかかっているのですが、こちらを回避する処理はありますでしょうか?
 
また、このコード自体間違っている等ありましたらご指摘ください。

回答
投稿日時: 21/03/12 15:16:33
投稿者: Suzu

引用:
クエリの種別フィールドごとにシート分ける処理を行いたいです。

 
今は、
 
  Set xls = CreateObject("Excel.Application")
  With xls
     (中略)
    Do Until rst.EOF
      .Cells(intRow, 1).Value = rst!番号
 
となっていますから、
 ExcelのアクティブシートのRangeに対して、値を与えています。
 
 
ここまでの コードが書けるのであれば、
シートを指定してそのシート上の Rangeオブジェクトに値を与えれば良いだけです。
 
 
引用:
上記で提示したコードを実行すると「実行中」のまま固まってしまいます。
恐らく処理に時間がかかっているのですが、こちらを回避する処理はありますでしょうか?

 
「固まる」と「実行中」は違います。
 
 .ScreenUpdating = False にしているから、
進捗が確認できないのでしょうから、確認してからの話ではありませんか?
 
処理の高速化という事であれば
 
・CopyFromRecordsetメソッド
https://docs.microsoft.com/ja-jp/office/vba/api/excel.range.copyfromrecordset
 
   Excelへの出力(DAO)
   https://www.moug.net/tech/acvba/0090011.html
 
 
また、シートごとに種類を分けたいという話であれば
・Filterプロパティー
https://docs.microsoft.com/ja-jp/office/client-developer/access/desktop-database-reference/recordset-filter-property-dao
 
 レコードを抽出する
 https://www.moug.net/tech/acvba/0080055.html
 
が使えます。

回答
投稿日時: 21/03/12 16:20:25
投稿者: sk

引用:
AccessのデータをExcelの任意のセルに出力したい

引用:
実行したいことは、 クエリの種別フィールドごとにシート分ける処理を行いたいです。

(標準モジュール)
---------------------------------------------------------------
Public Sub ExcelTemplateSample()
On Error GoTo Err_ExcelTemplateSample
   
  Dim dbs As Database
  Dim rstMemberTypes As Recordset
  Dim rstMembers As Recordset
   
  Dim xlsApp As Object 'Excel.Application
  Dim xlsNewBook As Object 'Excel.Workbook
  Dim xlsTemplateSheet As Object 'Excel.Worksheet
  Dim xlsNewSheet As Object 'Excel.Worksheet
   
  Dim strSQL As String
  Dim strSaveBookPath As String
   
  'テンプレートの保存先フォルダ
  Const cstrTemplateDir As String = "C:\name\Desktop\テンプレートファイル\"
  'テンプレートのファイル名
  Const cstrTemplateBook As String = "テンプレート.xlsx"
  'データが代入されたファイルの保存先フォルダ
  Const cstrSaveBookDir As String = "C:\Users\name\Desktop\"
 
  'テンプレートファイルが見つからない場合
  If Dir(cstrTemplateDir & cstrTemplateBook) = "" Then
    MsgBox "テンプレートファイルが見つかりません。" & vbCrLf & _
           "パス'" & cstrTemplateDir & cstrTemplateBook & "'が正しいかどうかを確認して下さい。", _
           vbExclamation, "実行中止"
    'プロシージャを抜ける
    Exit Sub
  End If
 
  'カレントデータベースの参照
  Set dbs = CurrentDb
   
  '[テンプレクエリ]の全てのレコードの[種類]を
  'グループ化した結果を得る SELECT 文の生成
  strSQL = "SELECT Nz(t1.[種類],'(不明)') AS [種類]" & _
           " FROM [テンプレクエリ] AS t1" & _
           " GROUP BY t1.[種類]" & _
           " ORDER BY t1.[種類];"
   
  'SELECT 文の結果をレコードセットとして開く
  Set rstMemberTypes = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
   
  'レコードがない場合
  If rstMemberTypes.EOF Then
    MsgBox "出力するレコードがありません。", vbExclamation, "実行中止"
    Set rstMemberTypes = Nothing
    Set dbs = Nothing
    'プロシージャを抜ける
    Exit Sub
  End If
 
  'Excelアプリケーションの新規インスタンスを生成
  Set xlsApp = CreateObject("Excel.Application")
   
  With xlsApp
     
    '警告メッセージの表示を無効に
    .DisplayAlerts = False
    '画面の再描画を抑止
    .ScreenUpdating = False
     
    'テンプレートファイルを元に新規ブックを作成
    Set xlsNewBook = .Workbooks.Add(cstrTemplateDir & cstrTemplateBook)
   
    'セルの再計算方式を手動に
    .Calculation = -4135 'xlCalculationManual
   
  End With
         
  'テンプレートとなるワークシートの参照を取得
  Set xlsTemplateSheet = xlsNewBook.Worksheets("原紙")
 
  '全ての[種類]を順次参照
  Do Until rstMemberTypes.EOF
    '現在の[種類]に該当するレコードを抽出する SELECT 文の生成
    strSQL = "SELECT t1.[番号], t1.[氏名], t1.[種類], t1.[金額]" & _
             " FROM [テンプレクエリ] AS t1" & _
             " WHERE Nz(t1.[種類],'(不明)') = '" & rstMemberTypes![種類] & "'" & _
             " ORDER BY [番号];"
 
    'SELECT 文の結果をレコードセットとして開く
    Set rstMembers = dbs.OpenRecordset(strSQL, dbOpenSnapshot)
       
    'レコードがある場合
    If Not rstMembers.EOF Then
       
      'テンプレートシートの前にそのコピーを挿入
      xlsTemplateSheet.Copy Before:=xlsTemplateSheet
      '挿入した新しいシートを参照
      Set xlsNewSheet = xlsTemplateSheet.Previous
       
      '新しいシートの編集
      With xlsNewSheet
        'シート名の設定
        .Name = rstMemberTypes![種類]
        'レコードセットを A10 セルに貼り付け
        .Cells(10, 1).CopyFromRecordset rstMembers
        'A1セルを選択
        .Cells(1, 1).Select
      End With
     
    End If
       
    Set rstMembers = Nothing
       
    '次の[種類]へ
    rstMemberTypes.MoveNext
  Loop
     
  'テンプレートシートを削除
  xlsTemplateSheet.Delete
  Set xlsTemplateSheet = Nothing
     
  '最初のワークシートを選択
  xlsNewBook.Worksheets(1).Select
     
  'セルの再計算方式を自動に
  xlsApp.Calculation = -4105 'xlCalculationAutomatic
     
  '保存するファイル名のフルパスを組み立て
  strSaveBookPath = cstrSaveBookDir & "注文書" & ".xlsx"
 
  'データを代入したブックを保存
  xlsNewBook.SaveAs strSaveBookPath
   
  MsgBox "'" & strSaveBookPath & "'にデータを出力しました。", vbInformation, "実行完了"
 
'終了処理
Exit_ExcelTemplateSample:
On Error Resume Next
     
  If Not xlsApp Is Nothing Then
    Set xlsNewSheet = Nothing
    Set xlsTemplateSheet = Nothing
     
    'セルの再計算方式を自動に
    xlsApp.Calculation = -4105 'xlCalculationAutomatic
     
    'ブックを閉じる
    xlsNewBook.Close False
    Set xlsNewBook = Nothing
       
    '画面の再描画を有効に
    xlsApp.ScreenUpdating = True
    '警告メッセージの表示を有効に
    xlsApp.DisplayAlerts = True
    'Excelを終了
    xlsApp.Quit
  End If
  Set xlsApp = Nothing
 
  Set rstMembers = Nothing
  Set rstMemberTypes = Nothing
  Set dbs = Nothing
 
 
  'プロシージャを抜ける
  Exit Sub
 
'エラー時処理
Err_ExcelTemplateSample:
  
  Dim strErr As String
  strErr = Err.Number & ":" & Err.Description
  
  Debug.Print strErr
   
  MsgBox strErr, vbCritical, "実行時エラー"
  
  '終了処理へ
  Resume Exit_ExcelTemplateSample
End Sub
---------------------------------------------------------------
 
以上のようなコードを記述したい、ということでしょうか。

投稿日時: 21/03/15 09:47:35
投稿者: MAXBOX

sk様
 
お返事が遅くなり申し訳ありません。
また、回答の方ありがとうございました。
 
こちらのコードで実行すると「パラメータが少なすぎます。1を指定してください」と表示されます。
 
こちらのエラーを経験したことがなく修正方法が分かりません、、
検索してみましたがあまり理解できずでした・・・
 
申し訳ありませんが、お力を貸して頂けると嬉しいです。
 
 

引用:
strSQL = "SELECT Nz(t1.[種類],'(不明)') AS [種類]" & _

こちらの(不明)とは何を入れたらよいのでしょうか?

回答
投稿日時: 21/03/15 10:36:37
投稿者: sk

markby さんの引用:
こちらのコードで実行すると
パラメータが少なすぎます。1を指定してください
と表示されます。

・変数 strSQL に格納されている SELECT 文において、
 いずれか 1 つのフィールドの名前の指定が正しくない。
 
・[テンプレクエリ]はパラメータクエリである。
 
考えられるのは以上のいずれか。
 
なお、markby さんの最初の投稿に関しては、
2 つのフィールドの名前に表記揺れが見られます。
 
markby さんの引用:
.Cells(intRow, 1).Value = rst!番号
.Cells(intRow, 2).Value = rst!氏名
.Cells(intRow, 3).Value = rst!種類
.Cells(intRow, 4).Value = rst!金額

markby さんの引用:
ID 氏名  種別 ・・・
1  ○○  特別会員
2  ○△  通常会員
3  ○✖  通常会員
4  ○□  特別会員
5  ✖□  ビジター

私が例示したコードについては、前者(モジュール側)での表記に
合わせています。
 
引用:
'[テンプレクエリ]の全てのレコードの[種類]を
'グループ化した結果を得る SELECT 文の生成
strSQL = "SELECT Nz(t1.[種類],'(不明)') AS [種類]" & _
         " FROM [テンプレクエリ] AS t1" & _
         " GROUP BY t1.[種類]" & _
         " ORDER BY t1.[種類];"

'現在の[種類]に該当するレコードを抽出する SELECT 文の生成
引用:
strSQL = "SELECT t1.[番号], t1.[氏名], t1.[種類], t1.[金額]" & _
         " FROM [テンプレクエリ] AS t1" & _
         " WHERE Nz(t1.[種類],'(不明)') = '" & rstMemberTypes![種類] & "'" & _
         " ORDER BY [番号];"

 
markby さんの引用:
こちらの(不明)とは何を入れたらよいのでしょうか?

それは「フィールド[種類]の値が Null である場合、Null の代わりに
"(不明)"という文字列を返す」という変換処理をやってるだけなので、
今のところはいじらなくてよいです。
 
まずは[テンプレクエリ]側の各フィールドの名前、および
パラメータの有無について確認を行なってください。

投稿日時: 21/03/15 11:00:05
投稿者: MAXBOX

sk様
クエリのフィールドを見直したところ入力ミスがありました!
修正したところ正常に動作し、完璧にインポートできました!!
感動です、、
本当にありがとうございました。
 
追加質問で本当に申し訳ありませんが1つお聞きしたいです。
今出力先は私のデスクトップにしていて、当分は私しか使わないのでこれでよいのですが
この先他の人も使うとなったとき私のデスクトップではなく、使っている人のデスクトップに出力したいです。
この場合どのように指定するとよいのでしょうか?
 
お手数ですが宜しくお願い致します。

回答
投稿日時: 21/03/15 11:24:24
投稿者: sk

引用:
今出力先は私のデスクトップにしていて、当分は私しか使わないのでこれでよいのですが
この先他の人も使うとなったとき私のデスクトップではなく、
使っている人のデスクトップに出力したいです。
この場合どのように指定するとよいのでしょうか?

エクスポート先の Excel ブックの保存先を
「実行中のユーザーのデスクトップ」にするのは良いとして、
テンプレートとなる Excel ブックについては
どこに保存しておくことを想定されているのでしょうか。
(定数 cstrTemplateDir と cstrSaveBookDir の値が
微妙に異なっていますし)
 
引用:
'テンプレートの保存先フォルダ
Const cstrTemplateDir As String = "C:\name\Desktop\テンプレートファイル\"
'テンプレートのファイル名
Const cstrTemplateBook As String = "テンプレート.xlsx"
'データが代入されたファイルの保存先フォルダ
Const cstrSaveBookDir As String = "C:\Users\name\Desktop\"

少なくとも、上記の 2 つについては定数ではなく変数として
宣言する必要があるでしょう。

投稿日時: 21/03/15 13:31:52
投稿者: MAXBOX

sk様
回答ありがとうございます。
 

引用:
少なくとも、上記の 2 つについては定数ではなく変数として
宣言する必要があるでしょう。

以上のアドバイスを受けて下記コードに変更しましたが合ってますでしょうか?
 
'テンプレートの保存先フォルダ
  Dim cstrTemplateDir As String
  cstrTemplateDir =  "C:\name\Desktop\テンプレートファイル\"
  'テンプレートのファイル名
  Const cstrTemplateBook As String = "テンプレート.xlsx"
  'データが代入されたファイルの保存先フォルダ
  Dim cstrSaveBookDir As String
  cstrSaveBookDir = "C:\Users\name\Desktop\"

 
 
引用:
テンプレートとなる Excel ブックについては
 どこに保存しておくことを想定されているのでしょうか。

テンプレートは共有のフォルダに保存するつもりです。
 
宜しくお願い致します。

回答
投稿日時: 21/03/15 13:47:57
投稿者: sk

引用:
テンプレートは共有のフォルダに保存するつもりです。

その場合、cstrTemplateDir については定数/変数のどちらでも構いません。
(パスさえ正しければ)
 
引用:
cstrSaveBookDir = "C:\Users\name\Desktop\"

Dim objWSH As Object
Set objWSH = CreateObject("WScript.Shell")
cstrSaveBookDir = objWSH.SpecialFolders("Desktop") & "\"
Set objWSH = Nothing

投稿日時: 21/03/15 14:34:07
投稿者: MAXBOX

sk様
 
最後までご回答いただき本当にありがとうございました。
おかげさまで私が実現したかったもの通りの仕様となりました。
 
困ったときはまたお力を貸して頂けると嬉しいです。
 
本当にありがとうございました。