'*******************************************************************************
' 新規ブックをマクロなしで作成するサンプル
'
' 作成者:井上治 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
'----------------------------<<>>--------------------------------