xlogI125’s blog

パソコン作業を効率化したい

トップ > VBA > Excelでファイル名を変更したい

Excelでファイル名を変更したい

VBA PowerShell ファイル名

大量のファイルに対して、ある程度の融通を利かせてリネームしたい場合に便利かもしれません。

例えば新版PDFと旧版PDFのページを1つのPDFに交互に並び替えたい場合に役立つと思います。
・PDF編集ソフトでPDFのページを分割
・分割されたPDFのファイル名を調整(新版: 1.pdf, 3.pdf, ... / 旧版: 2.pdf, 4.pdf, ...)
・PDF編集ソフトでPDFを結合

現在のファイル名を取得するためPowerShellで以下のコマンドを実行し、Excelに貼り付ける。

# PowerShell 5.1
Get-ChildItem | 
Select-Object -Property Attributes, FullName, Name, BaseName, Extension | 
ConvertTo-Csv -NoTypeInformation | 
Set-Clipboard

Excelに貼り付けた内容を以下のような形式に加工し、PowerShell側に貼り付けてリネームを行う。

Rename-Item -Path "oldName1.txt" -NewName "newName1.txt"
Rename-Item -Path "oldName2.txt" -NewName "newName2.txt"
Rename-Item -Path "oldName3.txt" -NewName "newName3.txt"

PowerShellを起動するのが面倒な場合はショートカットをSendToフォルダに作成しておき、作業したいフォルダでファイルを送ると少し楽になると思います。

ショートカット(.lnk)のリンク先(T):

powershell -NoLogo -NoExit -ExecutionPolicy Restricted -File -

ショートカット(.lnk)の作業フォルダー(S):

空欄

Excelでの作業効率を重視する場合のリンク先(T):

powershell -ExecutionPolicy Restricted -Command "Get-ChildItem | Select-Object -Property Name | ConvertTo-Csv -NoTypeInformation | Set-Clipboard; #"

SendToフォルダ (Windows 10 (2021年4月頃))

%USERPROFILE%\AppData\Roaming\Microsoft\Windows\SendTo

Excelで加工する際に文字列の結合が面倒であれば、下記のユーザー定義関数が便利です。

使い捨てマクロ

' Excel 2019
' 標準モジュール
Option Explicit

Public Function StrGetChildItem() As String
    StrGetChildItem = _
        "Get-ChildItem | " & _
        "Select-Object -Property Attributes, FullName, Name, BaseName, Extension | " & _
        "ConvertTo-Csv -NoTypeInformation | " & _
        "Set-Clipboard"
End Function

Public Function StrRenameItem(ByVal oldPath As String, ByVal newName As String) As String
    StrRenameItem = _
        "Rename-Item -Path """ & oldPath & """ -NewName """ & newName & """"
End Function

もしPowerShellを使用してはいけない場合、VBAでFileSystemObjectを使う方法も考えられます。

使い捨てマクロ

' Excel 2019

' 参照設定
' Library IWshRuntimeLibrary
'   Windows Script Host Object Model

Option Explicit

Public Sub GetChildItem()
    ' 選択したフォルダ内にある
    ' ファイル名とフォルダ名を新しいワークシートに書き出す

    ' エラー処理などは一切考慮していません

    Dim activeWb As Excel.Workbook
    Dim activeWs As Excel.Worksheet
    Dim ws As Excel.Worksheet
    Dim rng As Excel.Range
    Dim fd As Office.FileDialog
    Dim folderPath As String
    Dim fso As IWshRuntimeLibrary.FileSystemObject
    Dim fld As IWshRuntimeLibrary.folder
    Dim f As IWshRuntimeLibrary.File
    Dim d As IWshRuntimeLibrary.folder
    Dim filePaths As VBA.Collection
    Dim folderPaths As VBA.Collection
    Dim i As Long, j As Long

    Set activeWs = Excel.Application.ActiveSheet
    Set fd = activeWs.Application.FileDialog( _
                fileDialogType:=Office.MsoFileDialogType.msoFileDialogFolderPicker _
            )

    fd.Title = "パス取得"

    If fd.Show = -1 Then
        folderPath = fd.SelectedItems(1)
    Else
        VBA.Interaction.MsgBox _
            prompt:= _
            "フォルダが未選択です。" & VBA.Constants.vbCrLf & _
            "マクロを終了します。"
        Exit Sub
    End If

    Set fso = New IWshRuntimeLibrary.FileSystemObject
    Set fld = fso.GetFolder(folderPath:=folderPath)

    Set filePaths = New VBA.Collection

    ' 選択したフォルダ内にあるファイルのパス名を取り出す
    For Each f In fld.files
        filePaths.Add f.Path
    Next f

    Set folderPaths = New VBA.Collection

    ' 選択したフォルダ内にあるフォルダのパス名を取り出す
    For Each d In fld.SubFolders
        folderPaths.Add d.Path
    Next d

    Set activeWb = activeWs.Parent
    
    ' 新しいワークシートを追加する
    Set ws = activeWb.Sheets.Add( _
                after:=activeWb.Worksheets(activeWb.Worksheets.Count) _
                )

    i = 1

    For j = 1 To filePaths.Count Step 1
        Set rng = ws.Cells(i, 1)
        rng.Value = "file"
        Set rng = ws.Cells(i, 2)
        rng.Value = filePaths(j)
        Set rng = ws.Cells(i, 3)
        rng.Value = VBA.Constants.vbNullString
        Set rng = ws.Cells(i, 4)
        rng.Value = fso.GetBaseName(filePaths(j))
        Set rng = ws.Cells(i, 5)
        rng.Value = fso.GetExtensionName(filePaths(j))
        If rng.Value <> VBA.Constants.vbNullString Then
            rng.Value = "." & rng.Value
        End If
        Set rng = ws.Cells(i, 6)
        rng.Value = fso.GetFile(filePaths(j)).Type
        Set rng = ws.Cells(i, 7)
        rng.Value = fso.GetFile(filePaths(j)).Size
        i = i + 1
    Next j

    For j = 1 To folderPaths.Count Step 1
        Set rng = ws.Cells(i, 1)
        rng.Value = "folder"
        Set rng = ws.Cells(i, 2)
        rng.Value = folderPaths(j)
        Set rng = ws.Cells(i, 3)
        rng.Value = VBA.Constants.vbNullString
        Set rng = ws.Cells(i, 4)
        rng.Value = fso.GetFolder(folderPaths(j)).Name
        Set rng = ws.Cells(i, 5)
        rng.Value = VBA.Constants.vbNullString
        Set rng = ws.Cells(i, 6)
        rng.Value = fso.GetFolder(folderPaths(j)).Type
        Set rng = ws.Cells(i, 7)
        ' 「実行時エラー 70 書き込みできません」という
        ' エラーが出る場合は諦めてください。
        rng.Value = fso.GetFolder(folderPaths(j)).Size
        i = i + 1
    Next j

End Sub

Public Sub RenameItem()
    ' ワークシート上の選択範囲(Selection)の内容でファイル名の変更を行います
    '  1列目 ... fileとfolderの区別
    '  2列目 ... 古いパス名
    '  3列目 ... 新しいファイル名か新しいフォルダ名

    ' エラー処理などは一切考慮していません

    Const numColPathType As Long = 1
    Const numColPathOld As Long = 2
    Const numColNameNew As Long = 3
    Dim ws As Excel.Worksheet
    Dim slctRng As Excel.Range
    Dim rng As Excel.Range
    Dim pathType As String
    Dim filePathOld As String, filePathNew As String
    Dim folderPathOld As String, folderPathNew As String
    Dim fileNameNew As String
    Dim folderNameNew As String
    Dim fso As IWshRuntimeLibrary.FileSystemObject
    Dim fp As IWshRuntimeLibrary.File
    Dim dp As IWshRuntimeLibrary.folder
    Dim rowXlWsBegin As Long, colXlWsBegin As Long
    Dim rowXlWsEnd As Long, colXlWsEnd As Long
    Dim i As Long

    Set slctRng = Excel.Application.Selection
    Set ws = slctRng.Parent

    Set fso = New IWshRuntimeLibrary.FileSystemObject

    ' Selection側の座標をワークシート側の座標に換算する
    rowXlWsBegin = slctRng.Row
    colXlWsBegin = slctRng.Column
    rowXlWsEnd = rowXlWsBegin + slctRng.Rows.Count - 1
    colXlWsEnd = colXlWsBegin + slctRng.Columns.Count - 1

    For i = rowXlWsBegin To rowXlWsEnd Step 1
        ' Selectionの1列目
        Set rng = ws.Cells(i, colXlWsBegin + numColPathType - 1)
        pathType = rng.Value

        Select Case pathType
            Case "file"
                ' Selectionの2列目
                Set rng = ws.Cells(i, colXlWsBegin + numColPathOld - 1)
                filePathOld = rng.Value

                ' Selectionの3列目
                Set rng = ws.Cells(i, colXlWsBegin + numColNameNew - 1)
                fileNameNew = rng.Value

                filePathNew = fso.BuildPath( _
                                fso.GetParentFolderName(filePathOld), fileNameNew _
                                )
                Set fp = fso.GetFile(filePathOld)

                If Not fso.FileExists(filePathOld) Then
                    VBA.Interaction.MsgBox _
                        prompt:="ファイルが存在しません: " & filePathOld
                    Exit Sub
                End If

                If fso.FileExists(filePathNew) Then
                    VBA.Interaction.MsgBox _
                        prompt:="同名のファイルが存在します: " & filePathNew
                    Exit Sub
                End If

                fp.Name = fileNameNew

            Case "folder"
                ' Selectionの2列目
                Set rng = ws.Cells(i, colXlWsBegin + numColPathOld - 1)
                folderPathOld = rng.Value

                ' Selectionの3列目
                Set rng = ws.Cells(i, colXlWsBegin + numColNameNew - 1)
                folderNameNew = rng.Value

                folderPathNew = fso.BuildPath( _
                                fso.GetParentFolderName(folderPathOld), folderNameNew _
                                )
                Set dp = fso.GetFolder(folderPathOld)

                If Not fso.FolderExists(folderPathOld) Then
                    VBA.Interaction.MsgBox _
                        prompt:="フォルダが存在しません: " & folderPathOld
                    Exit Sub
                End If

                If fso.FolderExists(folderPathNew) Then
                    VBA.Interaction.MsgBox _
                        prompt:="同名のフォルダが存在します: " & folderPathNew
                    Exit Sub
                End If

                dp.Name = folderNameNew

            Case Else
                VBA.Interaction.MsgBox _
                    prompt:="1列目には file か folder を入力してください"
                Stop

        End Select

    Next i

End Sub