新しいExcelのファイルを作成する

新しいExcelのファイルを作成するプログラムを書いてみました。新しいExcelファイルを作成する上で事前に決めておくことは、ファイルをどこのフォルダに作成するかということです。そこで、ファイルパスをセルに入力するようにします。

A2セルにファイルパスを入力するようにしました。まず、入力されたパスが正しいか確認をします。(空白でないか、フォルダは存在するか)このとき、フォルダパスは入力されておらず、ファイル名のみ入力されることも考えてみました。もし、フォルダパスが入力されていない場合、実行ファイル(プログラムが存在するファイル)と同一のフォルダにファイルを作成することとします。プログラムとしては、ファイルパスを取得し、チェックした後、ファイルパスを戻り値で返すようにしました。

Private Function getFileName()

    'プログラム実行ファイルがアクティブになっていない可能性もあるため、実行ブックをアクティブにする
    ThisWorkbook.Activate

    'A2セルの文字列を取得
    Dim fPath As String
    fPath = Cells(2, "A").Value
        
    'A2セルの文字列が空白の場合
    If fPath = "" Then
        MsgBox "ファイル名を入力してください"
        Exit Function
    End If
    
    'A2セルの文字列の末尾が「.xls」じゃなかったら、付加する
    If Right(fPath, 4) <> ".xls" Then
        fPath = fPath & ".xls"
    End If
    
    'ファイル名の中に「\」が存在する場合
    If InStr(fPath, "\") Then
        'フォルダパス取得
        '(最後の「\」の文字まで切り取る)
        Dim folPath As String
        folPath = Left(fPath, InStrRev(fPath, "\"))
        
        'フォルダが存在するかチェック
        If Dir(folPath, vbDirectory) = "" Then
            MsgBox "フォルダが存在しません。"
        End If
    Else
        '実行ファイルのフォルダを親フォルダに設定
        fPath = ThisWorkbook.Path & "\" & fPath
    End If
    
    getFileName = fPath 'ファイル名をかえす
    
End Function

次にファイル作成処理です。ファイル作成はワークブックコレクション(開いているワークブックの集まり)にワークブックを追加します。追加したワークブックを名前をつけて保存するようにします。最後に保存したワークブックを閉じます。保存する際、同名のファイル名が存在した場合、上書き確認のメッセージがでます。今回は、新規で作成する場合を想定しているため、始めに同名のファイルが存在する場合はエラーで抜けるようにしました。

Public Sub CreateExcelFile()
       
    'A2セルのファイル名取得
    Dim fPath As String
    fPath = getFileName
    
    '同名のファイルが存在するか確認
    If Dir(fPath, vbNormal) <> "" Then
        MsgBox "同名のファイルが存在します。"
        Exit Sub
    End If
    
    'ワークブックの追加
    Workbooks.Add
    
    'アクティブワークブックをファイル名を指定して保存
    ActiveWorkbook.SaveAs (fPath)
    
    'アクティブワークブックを閉じる
    ActiveWorkbook.Close
    
End Sub