Excelで日程表を作ってみよう：Step1 日程用の新しいブックを作成する

ボタンクリックイベント
Private Sub CommandButton1_Click()
    MakeNitteiBook
End Sub

Excel VBA 標準モジュールコード

Public Sub MakeNitteiBook()
    Dim makefile As String
    Dim bookname As String
    
    '作成するファイル名
    makefile = GetSaveFileName
    If makefile = "" Then
        Exit Sub
    End If
    
    '新規にブックを作成
    NewBookMake makefile
    
    'ブック名を取得
    bookname = GetFileName(makefile)
    bookname = GetFileNameOnly(bookname)
    Workbooks(bookname).Activate
End Sub

'作成するファイル名
Public Function GetSaveFileName() As String
    Dim sfile As String

    sfile = Application.GetSaveAsFilename(fileFilter:="保存するエクセルファイル (*.xls), *.xls")
    If sfile = "False" Then
        GetSaveFileName = ""
    Else
        GetSaveFileName = sfile
    End If
End Function

'新規にブックを作成
Public Sub NewBookMake(filename As String)
    Dim tFile As Workbook
    
    Set tFile = Workbooks.Add
    
    '上書きメッセージを表示させない
    Application.DisplayAlerts = False
    tFile.Saved = True
    tFile.SaveAs filename:=filename
    'tFile.Close
    Application.DisplayAlerts = True
End Sub

'フルパスからファイル名のみ取得
Function GetFileName(fullpath As String) As String
    Dim i As Integer
    Dim nlen As Integer
    Dim s As String

On Error GoTo Errsub
    nlen = Len(fullpath)
    For i = nlen To 0 Step -1
        s = Mid$(fullpath, i, 1)
        If s = "\" Then Exit For
    Next
    s = Right$(fullpath, nlen - i)
    GetFileName = s
    Exit Function
Errsub:
    GetFileName = ""
End Function

'ファイル名から拡張子を除く
Function GetFileNameOnly(sfina As String) As String
    Dim i As Integer
    Dim nlen As Integer
    Dim s1 As String
    Dim s2 As String

On Error GoTo Errsub
    s2 = ""
    For i = 1 To Len(sfina)
        s1 = Mid$(sfina, i, 1)
        If s1 <> "." Then
            s2 = s2 + s1
        Else
            Exit For
        End If
    Next
    GetFileNameOnly = s2
    Exit Function
Errsub:
    GetFileNameOnly = ""
End Function