きなこSHOW

自作プログラム置き場です。

AccessからExcelテンプレートをひな形にして新規Workbookを作成するVBAサンプル

AccessからExcelにデータを出力する場合、エクスポート機能を使うケースが多いのかなと思います。

Excel側のレイアウトがどうでもいいときは、OutputToか、トランスファーなんちゃらで良いのですが、レイアウトが作りこまれているExcelシートにデータ出力したいときは、Excelテンプレートを用意しておいて、それを元に新規シートを作りましょう。

新規シートを自動で作るサンプルコードを紹介します。

今回紹介するコードは、Excelのテンプレートを元に新規Worksheetを作成するプロシージャと使用例です。
作成したシートにデータを出力する処理はまた後日にでも紹介するとして、今回はWorksheetを自動作成するソースを紹介しましょう。

ExcelテンプレートをCopyして新規Sheetを作成するサンプル

まずは新規シートを作成するプロシージャです。
標準モジュールに以下のコードを貼り付けます。

Excelの新規シートを作るプロシージャ

ちょっと長いですが、なにも考えずにコピペしてもそれなりに動きます。

'***************************************************************************
'名称 :gbAddNewSheet
'機能 :指定されたBookに新規Worksheetを追加する
'引数 :robjAppExcel           (I )    Object      Excel Application
'   :vsTemplateDir          (I )    String      Templateディレクトリ
'   :vsTemplateFile         (I )    String      Templateファイル
'   :vsTemplateSheet        (I )    String      Templateシート
'   :robjBook               ( O)    Object      (返却用)Workbookオブジェクト参照
'   :rsMsg                  ( O)    String      エラーメッセージ
'戻り値:True = 正常終了, False = 異常終了
'作成 :2012/05/31 kinaccco
'更新 :
'***************************************************************************
Public Function gbAddNewSheet(ByRef robjAppExcel As Object _
                            , ByVal vsTemplateDir As String _
                            , ByVal vsTemplateFile As String _
                            , ByVal vsTemplateSheet As String _
                            , ByRef robjBook As Object _
                            , ByRef robjSheet As Object _
                            , Optional ByRef rsMsg As String = "") As Boolean
On Error GoTo ERR_SEC
Const C_PROC_NAME       As String = "gbAddNewSheet"
Dim bRet                As Boolean
Dim bHit                As Boolean
Dim sPath               As String
Dim objTemplateBook     As Object    'Excel.Workbook
Dim objTemplateSheet    As Object    'Excel.Worksheet

  '--- 初期値セット ---
  bRet = False
  Set robjSheet = Nothing
  rsMsg = ""
  
  '--- パラメータチェック ---
  If robjAppExcel Is Nothing Then
    rsMsg = "[ERR-01]Excelアプリケーション参照の受け渡しに失敗しました。"
    GoTo EXIT_SEC
  End If
  
  '--- テンプレート存在チェック --- '(1)
  If Len(vsTemplateDir) > 0 Or Len(vsTemplateFile) > 0 Or Len(vsTemplateSheet) > 0 Then
  
    If Len(vsTemplateDir) <= 0 Then
      rsMsg = "[ERR-02]テンプレート格納フォルダ名の受け渡しに失敗しました。"
      GoTo EXIT_SEC        
    End If
    If Len(vsTemplateFile) <= 0 Then
      rsMsg = "[ERR-03]テンプレートファイル名の受け渡しに失敗しました。"
      GoTo EXIT_SEC
    End If
    If Len(vsTemplateSheet) <= 0 Then
      rsMsg = "[ERR-04]テンプレートシート名の受け渡しに失敗しました。"
      GoTo EXIT_SEC
    End If
    
    sPath = vsTemplateDir
    If Right(sPath, 1) <> Chr(92) Then sPath = sPath & Chr(92)
    sPath = sPath & vsTemplateFile
    '--- ファイル存在チェック --- (1)
    If Dir(sPath) = "" Then
      rsMsg = "[ERR-05]テンプレートファイル「" & vsTemplateFile & "」が、" & vbCrLf _
          & "フォルダ「" & vsTemplateDir & "」に存在しません。"
      GoTo EXIT_SEC
    End If
  End If
  
  '--- テンプレートが指定された場合、シートを検出する ---
  If Len(sPath) > 0 Then
  
    '--- テンプレートを開く --- (2)
    Set objTemplateBook = robjAppExcel.Workbooks.Open(FileName:=sPath)
      
      '--- テンプレートから指定された名前のシートを検出する --- (3)
      bHit = False
      For Each objTemplateSheet In objTemplateBook.Worksheets
        If objTemplateSheet.Name = vsTemplateSheet Then
          bHit = True
          Exit For
        End If
      Next objTemplateSheet
      
      '--- 見つからなかった場合エラー処理 --- (4)
      If bHit = False Then
        objTemplateBook.Close SaveChanges:=False
        Set objTemplateBook = Nothing
        rsMsg = "[ERR-06]レポートひな型に指定されたファイル「" & vsTemplateFile _
              & "」にシート「" & vsTemplateSheet & "」が存在しません。"
        GoTo EXIT_SEC
      End If
      
      '--- 検出したシートをWorksheet変数に格納する ---  (5)
      Set objTemplateSheet = objTemplateBook.Worksheets(vsTemplateSheet)
    End If
    
    '--- 出力先Bookが作成されていない場合、新規作成する --- (6)
    If robjBook Is Nothing Then
      
      '--- WorkBookオブジェクトが未設定の場合、新規Bookを作成する ---
      If objTemplateSheet Is Nothing Then
      
        '--- テンプレートが指定されない場合、空の新規Workbookを作成する ---
        Set robjBook = robjAppExcel.Workbooks.Add(Template:=xlWorksheet)
      Else
      
        '--- 指定したシートをCOPYして新規Workbookを作成する ---
        objTemplateSheet.Copy
        Set robjBook = robjAppExcel.ActiveWorkbook
      End If
      
      '--- シートへの参照を取得 ---
      Set robjSheet = robjBook.Worksheets(1)
      
    Else
      If objTemplateSheet Is Nothing Then

        '--- テンプレートが指定されない場合、空の新規Worksheetを追加する --- (7)
        Set robjSheet = robjBook.Worksheets.Add(After:=robjBook.Worksheets(robjBook.Worksheets.Count))
      Else
        
        '--- テンプレートのCOPYを指定されたBookの右端に追加する --- (8)
        robjAppExcel.Windows(robjBook.Name).Visible = True
        objTemplateSheet.Copy After:=robjBook.Worksheets(robjBook.Worksheets.Count)
        Set robjSheet = robjBook.Worksheets(robjBook.Worksheets.Count)
      
      End If
      
      'robjAppExcel.Windows(robjBook.Name).Visible = false
    End If
    
    bRet = (Not robjSheet Is Nothing)
    
EXIT_SEC:
On Error Resume Next

  Set objTemplateSheet = Nothing
  If Not objTemplateBook Is Nothing Then
    objTemplateBook.Close SaveChanges:=False
    Set objTemplateBook = Nothing
  End If
  
  gbAddNewSheet = bRet
  
  Exit Function

ERR_SEC:
Set robjBook = Nothing
  rsMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
        "プロシージャ名: " & C_PROC_NAME & vbCrLf & _
        "エラー番号:" & Err.Number & vbCrLf & _
        "エラー内容:" & Err.Description
  GoTo EXIT_SEC
End Function

解説

このプロシージャでは受け取った引数の内容によって、Worksheetをひとつ持った新規Workbookを返したり、渡されたWorkbookに新規Worksheetを追加したりなどなどをコントロールしています。

  1. Excelアプリケーションへの参照と、Template のパス、ファイル名、シート名を引数で受け取ります。受け取ったらまず、Excelアプリケーションが存在するかチェックと、テンプレートが指定された場合、そのファイルが本当に存在するかチェックします。
  2. 存在する場合、テンプレートファイルを開きます。
  3. 開いたテンプレートBook内のシートに、第4引数で渡されたシート名と一致するものがあるか、Worksheetsコレクションをループして探します。
  4. 指定されたシートが見つからない場合、エラーメッセージを返してプロシージャを抜けます。
  5. 指定されたシートが見つかった場合、そのシートを変数にセットします。
    (ここで新規Worksheetが作成されます。)
  6. 第5引数の出力先BookがNothingの場合、まだBookが作成されていないので、「Workbooks.Add」で出力先の新規Bookオブジェクトを作成します。
  7. Templateの指定なしでこのプロシージャが呼ばれた場合、新規Worksheetを作成します。
  8. 第5引数に出力先Bookが指定されている場合(=すでに存在するBookに新規シートを追加したい場合)、出力先Bookの末尾に作成されたWorksheetを作成します。

上記コードで、テンプレートありの場合と無しの場合、出力先Bookが存在する場合と指定なしで新規Bookを作成する場合の全パターンをカバーしています。
引数に渡しちゃならぬものが渡された場合は、もちろんエラーメッセージを返して以降の処理は行いません。

お次は、呼び出し側のサンプルコードです。

呼び出し側の例

Excelのテンプレート「納品書.xltx」をひな形に指定してシートを新規作成するプロシージャを呼び出すサンプルです。
次のようなコードを標準モジュールに記載します。

Public Function CallSample()
On Error GoTo ERR_SEC
Dim bRet                As Boolean
Dim sMsg                As String
Dim sTemplateDir        As String
Dim sTemplateBookName   As String
Dim sTemplateSheetName  As String
Dim sOutputPath         As String
Dim sOutputFileName     As String
Dim sOutputSheetName    As String
Dim objAppExcel         As Object
Dim objNewBook          As Object   'As Excel.Workbook
Dim objNewSheet         As Object   'As Excel.Worksheet
  
  '--- 初期値セット ---    
  bRet = False    
  sMsg = ""
  
  '--- 入出力ファイル情報を設定する --- (1)
  sTemplateDir = CurrentProject.Path
  sTemplateBookName = "納品書.xltx"
  sTemplateSheetName = "納品書"
  sOutputFileName = "納品書" & Format(Date, "yyyymmdd") & ".xlsx" '(2) 
  sOutputSheetName = "納品書" & Format(Date, "yyyymmdd")
  
  '--- ExcelAppオブジェクトを作成する --- (3)
  Set objAppExcel = CreateObject("Excel.Application")
  With objAppExcel
    .Visible = False
    .ScreenUpdating = False
    .DisplayAlerts = False
  End With

  '--- 出力先Excel 新規Bookを作成 --- (4)
  If gbAddNewSheet(objAppExcel, sTemplateDir, sTemplateBookName, sTemplateSheetName, objNewBook, objNewSheet, sMsg) = False Then
    Set objNewSheet = Nothing
    If Not objNewBook Is Nothing Then
      objNewBook.Close
      Set objNewBook = Nothing
    End If
    If Len(sMsg) <= 0 Then
      sMsg = "ExcelBook(" & sOutputFileName & ")の生成に失敗しました"
      GoTo EXIT_SEC   '(5)
    End If
  End If

  '(ここにデータ出力処理などを記述)

  '--- Bookを保存する --- (6)
  objNewSheet.Name = sOutputSheetName
  sOutputPath = CurrentProject.Path
  If Right(sOutputPath, 1) <> Chr(92) Then
    sOutputPath = sOutputPath & Chr(92)
  End If
  sOutputPath = sOutputPath & sOutputFileName
  objNewBook.SaveAs FileName:=sOutputPath
  bRet = True
      
EXIT_SEC:
On Error Resume Next

    '--- ExcelAppオブジェクトを終了して変数を解放する --- (7)
    If Not objAppExcel Is Nothing Then
      With objAppExcel
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Quit
      End With
      Set objAppExcel = Nothing
    End If
    If bRet Then
      MsgBox "正常終了"
    ElseIf sMsg <> "" Then
      MsgBox sMsg
    Else
      MsgBox "エラーが発生しました!"
    End If

  Exit Function

ERR_SEC:
    sMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
         "プロシージャ名: Sample" & vbCrLf & _
         "エラー番号:" & Err.Number & vbCrLf & _
         "エラー内容:" & Err.Description
    GoTo EXIT_SEC

End Function

 

  1. Templateのファイル名とシート名を次のプロシージャを呼び出すときの引数用の変数にセットして 
  2. あとで保存するときに付ける用のファイル名を作成しておきます。
  3. 次に、Excel Applicationオブジェクトを新規作成して、
  4. 先ほどのExcel新規シート作成プロシージャ「gbAddNewSheet」を呼び出します。
  5. 何らかのエラーが発生したときは以降の処理は行わずに抜けています。
  6. 「gbAddNewSheet」が正常に終了したらファイル名を付けて保存します。
  7. 初めに生成したExcel Applicationを終了して、変数を解放します。

ちなみに「gbAddNewSheet」でひな形として指定できるのは、Excelテンプレ―ト限定ではなく、拡張子が「xlsx」の普通のExcel Bookでも、旧型式の「xls」でも大丈夫です。テンプレファイル名に空文字(””)を指定することで、空のシートを作る仕組みになっています。

 

Excelから呼び出すサンプル

呼び出し側サンプルコードの「CurrentProject.Path」を「ThisWorkbook.Path」に書き換えるだけで、このモジュールをExcelからも実行することができます。

Public Function Sample_fromExcel()
On Error GoTo ERR_SEC
Dim bRet                As Boolean
Dim sMsg                As String
Dim sTemplateDir        As String
Dim sTemplateBookName   As String
Dim sTemplateSheetName  As String
Dim sOutputPath         As String
Dim sOutputFileName     As String
Dim sOutputSheetName    As String
Dim objAppExcel         As Object
Dim objNewBook          As Object   'As Excel.Workbook
Dim objNewSheet         As Object   'As Excel.Worksheet

    '--- 初期値セット ---
    bRet = False
    sMsg = ""
    
    '--- 入出力ファイル情報を設定する ---
    sTemplateDir = ThisWorkbook.Path
    sTemplateBookName = "23670_suitoutyou.xlsx"
    sTemplateSheetName = "現金出納帳"
    sOutputFileName = "現金出納帳" & Format(Date, "yyyymmdd") & ".xlsx"
    sOutputSheetName = "現金出納帳" & Format(Date, "yyyymmdd")
    
    '--- ExcelAppオブジェクトを作成する ---
    Set objAppExcel = CreateObject("Excel.Application")
    With objAppExcel
        .Visible = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    '--- 出力先Excel 新規Bookを作成 ---
    If gbAddNewSheet(objAppExcel, sTemplateDir, sTemplateBookName, sTemplateSheetName, objNewBook, objNewSheet, sMsg) = False Then
        Set objNewSheet = Nothing
        If Not objNewBook Is Nothing Then
            objNewBook.Close
            Set objNewBook = Nothing
        End If
        If Len(sMsg) <= 0 Then
            sMsg = "ExcelBook(" & sOutputFileName & ")の生成に失敗しました"
            GoTo EXIT_SEC
        End If
    End If

'(ここにデータ出力処理などを記述)

    '--- Bookを保存する ---
    objNewSheet.Name = sOutputSheetName
    sOutputPath = ThisWorkbook.Path
    If Right(sOutputPath, 1) <> "" Then
        sOutputPath = sOutputPath & ""
    End If
    
    sOutputPath = sOutputPath & sOutputFileName
    objNewBook.SaveAs Filename:=sOutputPath
    bRet = True

EXIT_SEC:
On Error Resume Next

    '--- ExcelAppオブジェクトを終了して変数を解放する ---
    If Not objAppExcel Is Nothing Then
        With objAppExcel
            .DisplayAlerts = True
            .ScreenUpdating = True
            .Quit
        End With
        Set objAppExcel = Nothing
    End If
    
    If bRet Then
        MsgBox "正常終了"
    ElseIf sMsg <> "" Then
        MsgBox sMsg
    Else
        MsgBox "エラーが発生しました!"
    End If
    
    Exit Function

ERR_SEC:
    sMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
        "プロシージャ名: Sample" & vbCrLf & _
        "エラー番号:" & Err.Number & vbCrLf & _
        "エラー内容:" & Err.Description
    GoTo EXIT_SEC
End Function

この場合、Excel.Applicationは省いて大丈夫です。

 

さいごに

AccessからExcelに出力したい場面は多いと思いますが、決してクエリの結果をExcelに手作業で貼り付けたりしてはなりませぬ。このテクニックがお役に立てれば幸いです。