【VBA】フォルダ作成ツール（簡易）

はじめに

初めまして、T4exf63です。
この間配属先の変更があったのですが、事務方が私のユーザー情報の引き継ぎがうまく行ってなかったせいで、私のローカルにあるツールや資料などがすべて消されてしまいました。
二度と同じ思いをしたくないので、それなら開き直って簡易的なツールをコピペできる状態でネット上に置いとこうと思い、今回投稿を決意しました。
幸い、Qiitaは閲覧可能な現場なので（閲覧不可になったら考えます。。。）

ネット上に転がってるものを持って来て現場で毎度作るのもいいのですが、いちいち作るのも馬鹿らしいし自分で作った方がバグったときにすぐわかるんで、コピペできるものを貼り付けておこうと思います。
なので、処理や説明が雑かもしれませんがご了承を。

本題

色々と投稿しようと思っていますが今回はVBAのファイル→フォルダ作成ツールです。
念のため、ライブラリ使用版とライブラリ未使用版の二つを上げておきます。
どちらも同じ処理です。

・開発環境

Microsoft Windows 11 Home
Microsoft Visual Basic for Application 7.1

・処理内容

至って普通で、エクセルのフォーマットは以下です。

セルA：項番
セルB：パス名（文末￥どちらでも可）
セルC：作成ファイル→フォルダ名
セルD：作成有無（〇・×）
セルE：備考（作成失敗時、原因出力）

・コード

ライブラリ使用版

Sub CreateFolder()
    '変数宣言
    Dim fso As Object
    Dim newFolder As Object
    Dim folderPath As String
    Dim i As Integer
    '初期化
    i = 0
    
    ' FileSystemObjectを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '作成対象がなくなるまで繰り返す
    Do Until Cells(3 + i, 2).Value = ""
        
        'パス名の文末に"\"があるか確認
        If Right(Cells(3 + i, 2).Value, 1) = "\" Then
            folderPath = Cells(3 + i, 2).Value & Cells(3 + i, 3).Value
        Else
            folderPath = Cells(3 + i, 2).Value & "\" & Cells(3 + i, 3).Value
        End If

        'パスが存在するか確認する
        If Not fso.FolderExists(folderPath) Then
            'エラー時対策
            On Error Resume Next
            ' 新しいフォルダを作成
            Set newFolder = fso.CreateFolder(folderPath)
            If Err.Number <> 0 Then
                'その他処理
                Cells(3 + i, 4).Value = "×"
                Cells(3 + i, 5).Value = "存在しないパス名なので、作成していません"
                Err.Clear
            Else
                'その他処理
                Cells(3 + i, 4).Value = "〇"
                Cells(3 + i, 5).Value = "-"
            End If
        Else
            ' パスが既に存在する場合はメッセージボックスを表示
            'その他処理
            Cells(3 + i, 4).Value = "×"
            Cells(3 + i, 5).Value = "指定されたパスは既に存在します。"
        End If
        
        ' オブジェクトを解放
        Set newFolder = Nothing
        'カウント
        i = i + 1
    Loop
    
    ' オブジェクトを解放
    Set fso = Nothing
        
    ' パスが既に存在する場合はメッセージボックスを表示
    MsgBox "処理が終了しました"

End Sub

ライブラリ未使用版

Sub CreateFolderNolibrary()
    Dim newFolder As String
    Dim folderPath As String
    Dim i As Integer
    i = 0

    Do Until Cells(3 + i, 2).Value = ""
        If Right(Cells(3 + i, 2).Value, 1) = "\" Then
            folderPath = Cells(3 + i, 2).Value & Cells(3 + i, 3).Value
        Else
            folderPath = Cells(3 + i, 2).Value & "\" & Cells(3 + i, 3).Value
        End If

        If Len(Dir(folderPath, vbDirectory)) = 0 Then
            On Error Resume Next
            MkDir folderPath
            If Err.Number <> 0 Then
                Cells(3 + i, 4).Value = "×"
                Cells(3 + i, 5).Value = "存在しないパス名なので、作成していません"
                Err.Clear
            Else
                Cells(3 + i, 4).Value = "〇"
                Cells(3 + i, 5).Value = "-"
            End If
        Else
            Cells(3 + i, 4).Value = "×"
            Cells(3 + i, 5).Value = "指定されたパスは既に存在します。"
        End If

        i = i + 1
    Loop

    MsgBox "処理が終了しました"
End Sub

おわりに

今回載せたものはファイル権限について書いていないので、権限絡みでエラーが起きたら加筆するかもしれないです。
基本的に自堕落な人間なんで、必要にならないと作らないと思いますので、急ぎで必要だったらコメントください。もしかしたら頑張って作ります。

記：2023年5月6日　

・投稿内容の修正
ファイルとフォルダを間違えて記載していましたのでタイトルと、文章の一部を赤太文字で修正しています。
処理内容は変わっていないです。
別に修正しなくてもよかったのですが、次の内容がファイル作成するツールでしたので投稿内容が紛らわしくならないように修正しました。

【修正内容】ファイル→フォルダ

記：2023年5月13日