'=========================================================================================
' 237 InputBoxで入力したファイル名で指定のシートを保存する
'-----------------------------------------------------------------------------------------
'【ヒント】
' このマクロは、おためし機能の動作用のコードを含んでいます。（概ね下半分）
' ★★★の行またはサブプロシージャーが、タイトル機能に関係するコードです。（概ね上半分）


'=========================================================================================
' ◆標準モジュールのコード◆
'-----------------------------------------------------------------------------------------
Option Explicit
Dim 指定シート名 As String                      '★★★
Dim 新しいファイル名 As String                  '★★★
Dim パス As String                              '★★★
Dim フルパス As String                          '★★★
Dim タイトル As String
Dim スタイル As Long
Dim メッセージ As String
Dim 応答 As Variant


'=========================================================================================
Private Sub InputBoxで入力したファイル名で指定のシートを保存する() '★★★
    InputBoxでファイル名を入力する
    If 新しいファイル名 = "False" Then          'InputBox関数でキャンセルボタンが押された場合
        Exit Sub
    End If
    メッセージ = "ファイル名：" & 新しいファイル名 & " を、" & Chr(13) & Chr(13) & _
                パス & " フォルダに保存します"
    応答 = MsgBox(メッセージ, スタイル, タイトル)
    If 応答 = vbYes Then
        指定のシートを新しいブックにコピーして保存する
    End If
End Sub
'-----------------------------------------------------------------------------------------
Private Sub InputBoxでファイル名を入力する()    '★★★
    Sheets(指定シート名).Select                 'シートをアクティブにする
    パス = ActiveWorkbook.Path                  'パスを取得する ※2
    メッセージ = "このシートだけを新しいファイル名で保存します。" & Chr(13) & Chr(13) & _
            "ファイル名を入力してください、" & Chr(13) & _
            "拡張子（.xls）は不要です"
    新しいファイル名 = Application.InputBox(prompt:=メッセージ, _
           Title:=タイトル, Type:=2)            'ファイル名を入力
End Sub
'-----------------------------------------------------------------------------------------
Private Sub 指定のシートを新しいブックにコピーして保存する() '★★★
    Sheets(指定シート名).Copy                   'シートを新規ブックへコピー
    フルパス = パス & "\" & 新しいファイル名 & ".xls" 'パスと拡張子をつなげる
    ActiveWorkbook.SaveAs Filename:=フルパス    '新しいファイルを保存する
    ActiveWorkbook.Close                        '新しいファイルを閉じる
End Sub
'=========================================================================================
'＜コメント＞
'※1 Titleには、新しいファイル名で保存するシート名を記入
'※2 これをしないと、Excelのオプションのカレントフォルダ名の既定値（My Documents）で保存される



'-----------------------------------------------------------------------------------------
Sub おためしマクロ()
    おためしメッセージを準備する
    指定シート名 = "Title"                      '★★★ 新しいファイル名で保存するシート名 ※1
    InputBoxで入力したファイル名で指定のシートを保存する '★★★
End Sub
'-----------------------------------------------------------------------------------------
Private Sub おためしメッセージを準備する()
    Worksheets("Title").Select
    Range("P17").Select                        'カーソルを定位置へ移動する
    タイトル = "500連発 第2弾 サンプルマクロ"
    スタイル = 32 + 4                           'vbQuestion + vbYesNo
End Sub
'-----------------------------------------------------------------------------------------
Sub Auto_Close()
    Application.DisplayAlerts = False           '閉じる際に確認メッセージを出さない
    ActiveWorkbook.Close                        '現在開いているブックを閉じる
End Sub
'-----------------------------------------------------------------------------------------