Excel VBA 複数のファイル名の前、後に文字を一括で追加するサンプル

ブログでよく画像をスクショしますが、ファイル名を「01.png」「02.png」・・・と連番で保存します。

ブログにアップする時は、「aaa01.png」「aaa02.png」・・・のように連番の前に文字を追加するのですが、手作業は面倒です。

マクロにしておくと一瞬で終わりますよね。

そのサンプルです。

< スポンサーリンク >

ファイル名の前、後に文字を追加するサンプル
ファイル名の前に追加したい場合
ファイル名の後に追加したい場合

ファイル名の前、後に文字を追加するサンプル

マクロを組んでいるフォルダに「img」「img_backup」というフォルダを作りました。

「img」フォルダに「01.png」「02.png」の元画像を入れリネームします。

「img_backup」フォルダには、違う名前に変えたい時のために「01.png」「02.png」のバックアップをとるようにしました。

上図の「ファイル名リネーム.xlsm」の「B4」セルにファイル名の前か後につけたい文字列を入力できるようにします。

「B2」セルには、ファイル名の前か後かを選べるようにします。

［ファイル名リネーム］ボタンのコードは以下。

Private Sub CommandButton1_Click()
    'このブック
    Dim acWb As Workbook
    '画像用フォルダ
    Dim imgDirPath As String
    '画像バックアップ用フォルダ
    Dim bkDirPath As String
    '画像バックアップカウント用
    Dim bkCnt As Integer
    'ファイルシステムオブジェクト
    Dim FSO As Object
    'ファイルオブジェクト
    Dim FileObj As Object
    'アクティブなファイルオブジェクト
    Dim acFileObj As Object
    'アクティブなファイル名用
    Dim acFileObjName As String
    'ファイル名拡張子で分割用
    Dim fileNameSplit As Variant
    'B2のセル（ファイル名の前か後か）の値用
    Dim b2Str As String
    'B4のセル（ファイル名に付ける文字）の値用
    Dim b4Str As String
    
    'このブックをセット
    Set acWb = ThisWorkbook
    
    '画像用フォルダを指定
    imgDirPath = acWb.Path & "\img"
    '画像バックアップ用フォルダを指定
    bkDirPath = acWb.Path & "\img_backup"
    
    'アクティブシートのB2、B4の値を変数に入れる
    b2Str = ActiveSheet.Range("B2").Value
    b4Str = ActiveSheet.Range("B4").Value
    
    'ファイルシステムオブジェクトのセット
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    '画像バックアップ用フォルダにファイルが何個あるか
    bkCnt = FSO.GetFolder(bkDirPath).Files.Count
    '画像バックアップ用フォルダにファイルがあれば全消し
    If bkCnt > 0 Then
        Kill bkDirPath & "\*"
    End If
    
    '画像用フォルダ内のファイルのセット
    Set FileObj = FSO.GetFolder(imgDirPath).Files
    
    For Each acFileObj In FileObj
        acFileObjName = acFileObj.Name
        
        '画像バックアップ
        FileCopy imgDirPath & "\" & acFileObjName, bkDirPath & "\" & acFileObjName
        
        'ファイル名を拡張子で分割
        fileNameSplit = Split(acFileObjName, ".")
        
        'B2セルの名前を前に付けてリネーム
        If b2Str = "ファイル名の前につける" Then
            acFileObj.Name = b4Str & acFileObjName
        ElseIf b2Str = "ファイル名の後につける" Then
            acFileObj.Name = fileNameSplit(0) & b4Str & "." & fileNameSplit(1)
        End If
    Next acFileObj
    
    MsgBox "終了"
End Sub