【VBA】指定したフォルダ内のフォルダに連番（例: 01_フォルダ名）をつけるマクロ

Option Explicit

' フォルダ選択ダイアログを表示する関数
Function SelectFolder() As String
    Dim fd As FileDialog
    Dim folderPath As String
    
    ' フォルダ選択ダイアログを表示
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    fd.Title = "連番を付けたいフォルダが入っているフォルダを選択してください"
    
    If fd.Show = -1 Then
        folderPath = fd.SelectedItems(1)
    Else
        folderPath = ""
    End If
    
    SelectFolder = folderPath
End Function

' 連番を付けるメインの処理
Sub AddSequentialNumbersToFolders()
    Dim parentFolderPath As String
    Dim folder As Object
    Dim folderName As String
    Dim newFolderName As String
    Dim fso As Object
    Dim folderList As Object
    Dim number As Integer
    Dim usedNumbers As Collection
    Dim numPrefix As String
    Dim i As Integer
    Dim renamed As Boolean
    
    ' フォルダ選択ダイアログを表示
    parentFolderPath = SelectFolder
    If parentFolderPath = "" Then
        MsgBox "フォルダが選択されていません。"
        Exit Sub
    End If
    
    ' ファイルシステムオブジェクトの作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folderList = fso.GetFolder(parentFolderPath).SubFolders
    
    ' 使用済みの連番を保持するコレクションを作成
    Set usedNumbers = New Collection
    
    ' 既存の連番を取得し、使用済み番号を記録
    For Each folder In folderList
        folderName = folder.Name
        If folderName Like "##_*" Then
            numPrefix = Left(folderName, 2)
            If IsNumeric(numPrefix) Then
                If Not ItemExists(usedNumbers, CInt(numPrefix)) Then
                    usedNumbers.Add CInt(numPrefix) ' 使用済み番号を記録
                Else
                    ' 重複している場合は新しい番号を割り当てる
                    number = FindNextAvailableNumber(usedNumbers)
                    newFolderName = Format(number, "00") & "_" & Mid(folderName, 4)
                    Name parentFolderPath & "\" & folderName As parentFolderPath & "\" & newFolderName
                    Debug.Print "重複フォルダをリネームしました: " & folderName & " -> " & newFolderName
                    usedNumbers.Add number ' 新しい番号を使用済みに追加
                End If
            End If
        End If
    Next folder
    
    ' 連番がついていないフォルダに対して新しい番号を付ける
    For Each folder In folderList
        folderName = folder.Name
        
        ' フォルダ名に連番がついていない場合のみ処理
        If Not folderName Like "##_*" Then
            ' 重複しない連番を見つける
            number = FindNextAvailableNumber(usedNumbers)
            newFolderName = Format(number, "00") & "_" & folderName
            
            ' フォルダのリネーム
            On Error Resume Next
            Name parentFolderPath & "\" & folderName As parentFolderPath & "\" & newFolderName
            If Err.Number = 0 Then
                Debug.Print "新しいフォルダをリネームしました: " & folderName & " -> " & newFolderName
                usedNumbers.Add number ' 使用済み番号に追加
            Else
                Debug.Print "リネームエラー: " & folderName
            End If
            On Error GoTo 0
        End If
    Next folder
    
    MsgBox "フォルダのリネームが完了しました。"
End Sub

' 使用されていない最小の番号を探す関数
Function FindNextAvailableNumber(usedNumbers As Collection) As Integer
    Dim number As Integer
    number = 1
    Do While ItemExists(usedNumbers, number)
        number = number + 1
    Loop
    FindNextAvailableNumber = number
End Function

' コレクション内に指定した番号が存在するかチェックする関数
Function ItemExists(coll As Collection, item As Variant) As Boolean
    Dim i As Variant
    ItemExists = False
    For Each i In coll
        If i = item Then
            ItemExists = True
            Exit Function
        End If
    Next i
End Function
 

コードの説明

このVBAコードは、指定したフォルダ内のサブフォルダに対して、連番を付与するマクロです。すでに連番が付いているフォルダはその番号を保持し、番号が重複している場合は、新しい番号が付与されます。連番が付いていないフォルダには、空いている最小の番号（若い番号）から順に連番を付けます。

各部分の詳細説明：

  1. SelectFolder 関数:

    • ユーザーがフォルダを選択するためのダイアログを表示し、選択したフォルダのパスを返します。これが連番を付与する対象フォルダになります。

  2. AddSequentialNumbersToFolders サブプロシージャ:

    • このプロシージャがメインの処理を行います。
    • 選択したフォルダ内のサブフォルダに対して、連番を付ける処理を行います。
    • 既に番号が付いているフォルダをチェックし、番号が重複している場合は新しい番号を付与します。また、連番が付いていないフォルダには新しい番号を若い順に付与します。
    • 使用されている番号は usedNumbers コレクションに記録され、重複する番号が割り当てられないよう管理されます。

  3. FindNextAvailableNumber 関数:

    • 使用されていない最小の番号を探し出し、その番号を返す関数です。既に使用された番号があれば、それをスキップして次の番号を見つけます。

  4. ItemExists 関数:

    • 指定した番号がすでに使用済みかどうかを確認する関数です。usedNumbers コレクション内にその番号が存在するかをチェックし、結果を返します。

使い方

  1. VBAエディタを開く:

    • ExcelなどのVBAエディタを開きます。Alt + F11 を押すとVBAエディタが表示されます。

  2. 新しいモジュールを挿入:

    • VBAエディタの「挿入」メニューから「モジュール」を選択して、新しいモジュールを挿入します。

  3. コードを貼り付け:

    • 挿入したモジュールに、上記のVBAコードをコピーして貼り付けます。

  4. マクロを実行:

    • VBAエディタを閉じて、Excelに戻ります。
    • Alt + F8 を押して「マクロの実行」ウィンドウを開き、AddSequentialNumbersToFolders マクロを選択して「実行」ボタンを押します。

  5. フォルダ選択ダイアログ:

    • マクロを実行すると、連番を付けたいフォルダが入っている親フォルダを選択するダイアログが表示されます。対象フォルダを選択してください。

  6. 連番付与の結果:

    • 選択したフォルダ内のサブフォルダに対して、番号が付いていないフォルダには新しい連番が付与され、番号が重複しているフォルダには別の新しい番号が付けられます。
    • 既存の番号に重複がなければ、その番号は変更されません。

注意点

  • このマクロはサブフォルダに対してのみ動作します。ファイルには影響を与えません。
  • フォルダ名の先頭に2桁の数字（例: 01_フォルダ名）が付いているかどうかを基に処理が行われます。