ナンバリングしたファイル名を作成する

2024.06.22

ファイル名から、同じファイル名でナンバリングしたファイル名を作成します。
上書きしたくないが、同じファイル名にしたい場合に使用します。

例
C:\ExcelVBA\Test.xlsx → C:\ExcelVBA\Test.xlsx (Test.xlsxが無い場合)
C:\ExcelVBA\Test.xlsx → C:\ExcelVBA\Test_001.xlsx (既にTest.xlsxがある場合)
C:\ExcelVBA\Test.xlsx → C:\ExcelVBA\Test_002.xlsx (既にTest_001.xlsxがある場合)
C:\ExcelVBA\Test.xlsx → C:\ExcelVBA\Test_003.xlsx (既にTest_001.xlsx、Test_002.xlsxがある場合)

【関数化】

' ------------------------------------------------------------
' 説明：ファイル名から、同じファイル名でナンバリングしたファイル名を作成する
' 引数：1:元のファイル名
'       2:開始値(省略した場合は1から)
'       3:桁数(省略した場合は3)
' 戻値：ナンバリングしたファイル名
' 備考：同じ名前が無い場合はそのままファイル名を戻す
'       最大値は桁以上とする。桁数が3の場合 999 を上限とする。
'       最大値を超えた場合、ファイル名が未指定の場合
' ------------------------------------------------------------
Function FilenameAddNumber(filename As String, Optional start As Long = 1, Optional digit As Long = 3) As String
    Dim fso As Object
    Dim FolderName As String
    Dim BaseName As String
    Dim CheckName As String
    Dim ExtName As String
    Dim fmt As String
    Dim idx As Long
    Dim max_num As Long
    
    
    ' オブジェクトを作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    ' ファイル名が未指定の場合は何もなしで返す
    If filename = "" Then
        FilenameAddNumber = ""
        Exit Function
    End If
    
    
    ' ファイルの有無を確認
    If fso.FileExists(filename) = False Then
        ' 同じファイル名が無い場合はそのまま返す
        FilenameAddNumber = filename
        Exit Function
    End If
    
    
    ' ファイルパスを取得
    FolderName = fso.GetParentFolderName(filename)
    
    
    ' 拡張子の無いファイル名を取得
    BaseName = fso.GetBaseName(filename)
    ExtName = fso.GetExtensionName(filename)
    
    
    ' 最大値を設定。桁数が3の場合 999 を上限とする。
    max_num = (10 ^ digit) - 1
    
    
    ' 指定した桁数(引数:digit)で、開始値(start)から未使用のファイル名を探す
    For idx = start To max_num
        Select Case digit
            Case 2
                fmt = Format(idx, "00")
            Case 3
                fmt = Format(idx, "000")
            Case 4
                fmt = Format(idx, "0000")
            Case 5
                fmt = Format(idx, "00000")
            Case 6
                fmt = Format(idx, "000000")
            Case 7
                fmt = Format(idx, "0000000")
            Case 8
                fmt = Format(idx, "00000000")
            Case Else
                fmt = Format(idx, "0")
        End Select
        
        
        ' ファイル名を作成したら、同じファイル名が存在しないか確認する。
        ' 存在しない場合は、そのファイル名を戻す。
        ' 存在する場合は、インクリメントして、次のファイル名を確認する。
        CheckName = FolderName & "\" & BaseName & "_" & fmt & "." & ExtName
        If fso.FileExists(CheckName) = False Then     ' ファイルの有無を確認
            FilenameAddNumber = CheckName
            Exit Function
        End If
    Next
End Function

【修正】
2024/07/13 ファイル名が未指定の場合に関数を終了させるように Exit Function を追加
2025/10/13 指定したファイル名が無い場合、そのままファイル名を返すように修正

コメント