新規ブックをマクロなしで作成するサンプル

'******************************************************************************* 

'   新規ブックをマクロなしで作成するサンプル 

' 

'   作成者:井上治  URL:http://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!] 

'******************************************************************************* 

Option Explicit  

'******************************************************************************* 

'   新規ブックをマクロなしで作成するサンプル 

'******************************************************************************* 

Sub MAKE_NEWBOOK_WO_MACROS()

     Const cnsTITLE = "マクロなしブックの作成"

     Const cnsFILTER = "Excelワークブック (*.xls),*.xls"

     Dim xlAPP As Application

     Dim WBK1 As Workbook                    ' 本ブック

     Dim WBK2 As Workbook                    ' 作成ブック

     Dim strFILENAME As String

     Dim tblSH As Variant

     Dim lngLines As Long      ' 新規ブックに転出するシートの配列を作成

     tblSH = Array("Sheet1", "Sheet2", "Sheet3")

     Set xlAPP = Application

     Set WBK1 = ThisWorkbook                 ' 本ブック

     ' 「名前を付けて保存」のフォームでファイル名の指定を受ける

     xlAPP.StatusBar = "出力するファイル名を指定して下さい。"

     strFILENAME = xlAPP.GetSaveAsFilename(InitialFilename:="SAMPLE.xls", _

         FileFilter:=cnsFILTER, Title:=cnsTITLE)     

     ' キャンセルされた場合は以降の処理は行なわない

     If StrConv(strFILENAME, vbUpperCase) = "FALSE" Then Exit Sub

     If strFILENAME = WBK1.FullName Then

         MsgBox "本ブックとは違うファイル名を指定して下さい。",, cnsTITLE

         GoTo MAKE_NEWBOOK_WO_MACROS_EXIT

     End If     

     ' 指定シート(複数)を新規ブックにコピーする

     WBK1.Worksheets(tblSH).Copy

     Set WBK2 = ActiveWorkbook               ' コピーした新規ブック

     ' 処理ブックを保存

     WBK2.SaveAs Filename:=strFILENAME

     WBK2.Close False

     Set WBK2 = Nothing

MAKE_NEWBOOK_WO_MACROS_EXIT:

     Set WBK1 = Nothing

     Set xlAPP = Nothing End Sub

  '----------------------------<<>>--------------------------------