【VBA】ファイル名に連番を付けて保存する

エクセルVBAでよく使うコードの備忘録。保存ディレクトリに同名のファイルがある場合、VBAで重ね書きせずに連番を付けて保存するコード。

事前準備

特になし。

連番を付けて保存する

ファイルを保存する際に、同名のファイルがあれば連番を付けて保存します。拡張子の手前に連番を付けるため、ファイル名から拡張子を取得する関数とファイル名から拡張子を除外する関数を同時に使用しています。

サンプルコード

Public Sub GenerateSerialFilePath()
    
    '--- 保存ファイルのパスを格納する変数 ---'
    Dim strNewFilePath As String
    
    '--- ファイルの拡張子を格納する変数 ---'
    Dim strExt As String
    
    '--- 連番用の変数 ---'
    Dim i As Long
    
    '--- 連番用の文字列を保存する変数 ---'
    Dim strSerial As String
    
    '--- 連番がないファイル名 ---'
    Dim strOrgFileName As String
    strOrgFileName = "testtest.docx"
    
    '--- 保存フォルダのディレクトリ
    Dim strFileDir As String
    strFileDir = "[保存フォルダのパス]"
    
    '--- 連番がないファイルの保存パス ---'
    Dim strFilePath As String
    strFilePath = strFileDir & "\" & strOrgFileName
    
    If (Dir(strFilePath) <> "") Then
        '--- 連番がない同名のファイルが存在する場合 ---'
        
        'ファイルの拡張子を格納
        strExt = GetExtentionFromFileName(strOrgFileName)
        
        'ファイル名から拡張子を除く
        strOrgFileName = ExcludeExtention(strOrgFileName)
        
        '連番文字列を生成（この例はただの数字）
        i = 1
        strSerial = i
        
        '連番付きの新しいパスを生成
        strNewFilePath = strFileDir & "\" & strOrgFileName & strSerial & "." & strExt
        
        '連番付ファイルがある間はループ
        Do While (Dir(strNewFilePath) <> "")
            i = i + 1
            strSerial = i
            strNewFilePath = strFileDir & "\" & strOrgFileName & strSerial & "." & strExt
        Loop
        
    Else
        '--- 連番がない同名のファイルが存在しない場合 ---'
        strNewFilePath = strFilePath
        
    End If
    
End Sub

'--- ファイル名から拡張子を除外する関数 ---'
Public Function ExcludeExtention(strFileName As String) As String
    
    '--- 拡張子の位置 ---'
    Dim posExt As Long
    posExt = InStrRev(strFileName, ".")
    
    '--- 拡張子を除いたパス（ファイル名）を格納する変数 ---'
    Dim strFileExExt As String
    
    If (0 < posExt) Then
        strFileExExt = Left(strFileName, posExt - 1)
    Else
        strFileExExt = strFileName
    End If
    
    ExcludeExtention = strFileExExt
    
End Function

'--- ファイル名から拡張子を取得する関数 ---'
Public Function GetExtentionFromFileName(strFileName As String) As String
    
    '--- 拡張子の位置 ---'
    Dim posExt As Long
    posExt = InStrRev(strFileName, ".")
    
    '--- 拡張子を格納する変数 ---'
    Dim strExt As String
    
    If (0 < posExt) Then
        strExt = Right(strFileName, Len(strFileName) - posExt)
    Else
        strExt = ""
    End If
    
    GetExtentionFromFileName = strExt
    
End Function