2013年09月20日

AccessでExcelファイルのシートを複製

AccessでExcelファイルのシートを複製する方法です。

Excelのシートを複製して利用する場面って多くあります。
売上表のExcelファイルがあって、営業日の日付が入った日報シートを作る。
勤務表のExcelファイルがあって、社員番号の入った勤務シートを作る。
などのケースです。

以下は、"勤務表"のシートを元に、複製をしていくサンプルロジックです。
シンプルにする為、エラー処理は入れてませんので、ご理解ください。

==============================

Private Sub BTN_シート複製_Click()
Dim xlApp As Object
Dim xlBook As Object
Dim xlSheet As Object
Dim stFileName As String
Dim stSheetName As String
Dim lngCnt As Long

' 処理を開始するか確認
myButton = MsgBox("処理を開始します。よろしいですか?", vbYesNo, "勤務管理システム")

If myButton = vbYes Then

DoCmd.Hourglass True ' マウスを砂時計に切り替えます。

cnt = DCount("*", "QW_社員マスタ") ' 対象件数の取得
stFileName = "D:\勤務管理システム\勤務表テンプレート.xlsx" ' Excelファイル名
stSheetName = "勤務表" ' 元になるシート

' Excel展開
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(stFileName)

' コピー先の位置取得
For Each xlSheet In xlBook.Worksheets
lngCnt = lngCnt + 1
Next

' 複製シート生成
For i = 1 To cnt Step 1

' シートコピー
Set xlSheet = xlBook.Worksheets(stSheetName)
xlSheet.Copy , xlBook.Worksheets(lngCnt)

' シート名変更
lngCnt = lngCnt + 1
Set xlSheet = xlBook.Worksheets(lngCnt)
xlSheet.Name = stSheetName & Trim(StrConv(Str(i), vbWide))
Next i

' エクセルファイルを閉じる
xlBook.Close (True)
xlApp.Quit

' オブジェクトの開放
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing

DoCmd.Hourglass False ' マウスを元に戻します。

' メッセージ
MsgBox "処理が終了しました。", vbOKOnly + vbExclamation, "勤務管理システム"
End If
End Sub


==========



コメントを入れているので、特に難しいところは無いと思いますが、
補足としては2点あります。

1点目は、シートの複製位置です。
最初のFor文にて、シートが何枚あるのか数えており、
それを元に、コピーするシートを何処に置くのか判断材料にしてます。

2点目は、シート名称です。
"勤務表"を元に、生成すると1シート目は"勤務表1"となります。
2番目のFor文のカウンタを利用しているのですが、
あえて半角数字を全角数字に変えてから結合してます。

発展系としては、社員番号をシート名にしたり、
その日に取引のあったお客様名称にするなどでしょうか。
工夫次第で用途は広がりますね。  


Posted by 大樹直人 (naohito ooki) at 11:15Comments(0)VBA