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を追加したりなどなどをコントロールしています。
- Excelアプリケーションへの参照と、Template のパス、ファイル名、シート名を引数で受け取ります。受け取ったらまず、Excelアプリケーションが存在するかチェックと、テンプレートが指定された場合、そのファイルが本当に存在するかチェックします。
- 存在する場合、テンプレートファイルを開きます。
- 開いたテンプレートBook内のシートに、第4引数で渡されたシート名と一致するものがあるか、Worksheetsコレクションをループして探します。
- 指定されたシートが見つからない場合、エラーメッセージを返してプロシージャを抜けます。
- 指定されたシートが見つかった場合、そのシートを変数にセットします。
(ここで新規Worksheetが作成されます。) - 第5引数の出力先BookがNothingの場合、まだBookが作成されていないので、「Workbooks.Add」で出力先の新規Bookオブジェクトを作成します。
- Templateの指定なしでこのプロシージャが呼ばれた場合、新規Worksheetを作成します。
- 第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
- Templateのファイル名とシート名を次のプロシージャを呼び出すときの引数用の変数にセットして
- あとで保存するときに付ける用のファイル名を作成しておきます。
- 次に、Excel Applicationオブジェクトを新規作成して、
- 先ほどのExcel新規シート作成プロシージャ「gbAddNewSheet」を呼び出します。
- 何らかのエラーが発生したときは以降の処理は行わずに抜けています。
- 「gbAddNewSheet」が正常に終了したらファイル名を付けて保存します。
- 初めに生成した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に手作業で貼り付けたりしてはなりませぬ。このテクニックがお役に立てれば幸いです。