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

メモ

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

Excelでマクロを使うよりも、PowerShellの実行結果をExcelシートに貼り付けて加工するほうが作業的に早い気もします。

使い捨てマクロ

' Excel 2019
' Windows 10

' [参照設定]
' ツール(T) -> 参照設定(R)
' 参照可能なライブラリファイル(A)
'  Microsoft Scripting Runtime
'  "C:\Windows\System32\scrrun.dll"

' ・エラー処理などは考慮していません
' ・重複チェックはワークシート上で実施してください

Option Explicit

Private Enum ColNum
  ColOldFileName = 1
  ColNewFileName
  ColTmpFileName
  ColFolderPath
  ColOldBaseName
  ColOldExtension
End Enum

Private Enum RowNum
  RowDataBegin = 1
End Enum

Public Sub GetChildItemFile()
  ' ワークブックを新規作成してワークシートに
  '  1列目: フォルダにあるファイルのファイル名
  '  2列目: 新しいファイル名の例
  '  3列目: 一時ファイル名の例
  '  4列目: フォルダパス
  '  5列目: フォルダにあるファイルのベース名
  '  6列目: フォルダにあるファイルのファイル拡張子名+ピリオド
  ' を書き出す。

  Dim fso As Scripting.FileSystemObject
  Dim fld As Scripting.Folder
  Dim fs As Scripting.Files
  Dim f As Scripting.File
  Dim folderPath As String
  Dim str As String
  Dim tmpSplit() As String
  Dim i As Long

  Dim wb As Excel.Workbook
  Dim ws As Excel.Worksheet
  Dim rng As Excel.Range
  Dim rngValue() As String

  Set fso = New Scripting.FileSystemObject

  str = VBA.Interaction.InputBox( _
    Prompt:= _
      "[入力例1]" & VBA.Constants.vbCrLf & _
      "フォルダのパスを入力してください" & VBA.Constants.vbCrLf & _
      "例)" & VBA.Constants.vbCrLf & _
      "C:\Users\xxxxx\Desktop\yyyyy" & VBA.Constants.vbCrLf & _
      VBA.Constants.vbCrLf & _
      "[入力例2]" & VBA.Constants.vbCrLf & _
      "デスクトップ上でファイルを「Shift+左クリック」して表示される" & VBA.Constants.vbCrLf & _
      "「パスのコピー(A)」の結果を貼り付けてください" & VBA.Constants.vbCrLf & _
      "例)" & VBA.Constants.vbCrLf & _
      """C:\Users\xxxxx\Desktop\yyyyy\zzzzz.txt""" & VBA.Constants.vbCrLf, _
    Title:="フォルダのパスを入力", _
    Default:="C:\Users\xxxxx\Desktop\yyyyy" _
    )

  tmpSplit = VBA.Strings.Split( _
    Expression:=str, _
    Delimiter:="""", _
    Limit:=-1, _
    Compare:=VBA.VbCompareMethod.vbBinaryCompare _
    )

  If (UBound(tmpSplit) < 0) Then
    VBA.Interaction.MsgBox _
      Prompt:= _
        "入力欄が空欄" & VBA.Constants.vbCrLf & _
        "または" & VBA.Constants.vbCrLf & _
        " キャンセルボタンが押されました" & VBA.Constants.vbCrLf & _
        VBA.Constants.vbCrLf & _
        "マクロを終了します", _
      Buttons:=VBA.VbMsgBoxStyle.vbOKOnly, _
      Title:="入力欄が空欄 または キャンセルボタン"
    Exit Sub
  End If

  If (UBound(tmpSplit) = 0) Then
    ' フォルダのパスに"が含まれていない場合
    folderPath = str
  Else
    ' フォルダのパスに"が含まれている場合
    str = VBA.Strings.Replace( _
      Expression:=str, _
      Find:="""", _
      Replace:="", _
      Start:=1, _
      Count:=-1, _
      Compare:=VBA.VbCompareMethod.vbBinaryCompare _
      )
    folderPath = fso.GetParentFolderName(Path:=str)
  End If

  If Not fso.FolderExists(FolderSpec:=folderPath) Then
    VBA.Interaction.MsgBox _
      Prompt:= _
        "下記のフォルダが存在しません" & VBA.Constants.vbCrLf & _
        VBA.Constants.vbCrLf & _
        folderPath & VBA.Constants.vbCrLf & _
        VBA.Constants.vbCrLf & _
        "マクロを終了します", _
      Buttons:=VBA.VbMsgBoxStyle.vbOKOnly, _
      Title:="フォルダが存在しません"
    Exit Sub
  End If

  Set fld = fso.GetFolder(folderPath)
  Set fs = fld.Files

  If fs.Count = 0 Then
    VBA.Interaction.MsgBox _
      Prompt:= _
        "下記のフォルダにファイルが存在しません" & VBA.Constants.vbCrLf & _
        VBA.Constants.vbCrLf & _
        folderPath & VBA.Constants.vbCrLf & _
        VBA.Constants.vbCrLf & _
        "マクロを終了します", _
      Buttons:=VBA.VbMsgBoxStyle.vbOKOnly, _
      Title:="ファイルが存在しません"
    Exit Sub
  End If

  ReDim rngValue(1 To fs.Count, 1 To ColNum.ColOldExtension)

  i = 1

  For Each f In fs
    rngValue(i, ColNum.ColOldFileName) = f.Name
    rngValue(i, ColNum.ColNewFileName) = "NEW_" & f.Name
    rngValue(i, ColNum.ColTmpFileName) = "TEMP_" & f.Name
    rngValue(i, ColNum.ColFolderPath) = fso.GetParentFolderName(f.Path)
    rngValue(i, ColNum.ColOldBaseName) = fso.GetBaseName(f.Path)
    rngValue(i, ColNum.ColOldExtension) = "." & fso.GetExtensionName(f.Path)
    i = i + 1
  Next f

  Set wb = Excel.Workbooks.Add(Template:=Excel.XlWBATemplate.xlWBATWorksheet)
  Set ws = wb.Sheets(1)
  ws.Name = "ファイル名変更"

  Set rng = ws.Range( _
    ws.Cells(RowNum.RowDataBegin, ColNum.ColOldFileName), _
    ws.Cells(RowNum.RowDataBegin + fs.Count - 1, ColNum.ColOldExtension) _
    )
  rng.NumberFormatLocal = "@"
  rng = rngValue
  rng.Columns(ColNum.ColOldFileName).Interior.Color _
    = VBA.Information.RGB(Red:=255, Green:=242, Blue:=204)
  rng.Columns(ColNum.ColNewFileName).Interior.Color _
    = VBA.Information.RGB(Red:=255, Green:=242, Blue:=204)
  rng.Columns(ColNum.ColTmpFileName).Interior.Color _
    = VBA.Information.RGB(Red:=255, Green:=242, Blue:=204)
  rng.Columns(ColNum.ColFolderPath).Interior.Color _
    = VBA.Information.RGB(Red:=255, Green:=242, Blue:=204)
  rng.Columns(ColNum.ColOldBaseName).Interior.Color _
    = VBA.Information.RGB(Red:=221, Green:=235, Blue:=247)
  rng.Columns(ColNum.ColOldExtension).Interior.Color _
    = VBA.Information.RGB(Red:=221, Green:=235, Blue:=247)

  rng.Sort _
    Key1:=rng.Columns(ColNum.ColOldBaseName), _
    Order1:=Excel.XlSortOrder.xlAscending, _
    Header:=Excel.XlYesNoGuess.xlNo, _
    MatchCase:=False, _
    Orientation:=Excel.XlSortOrientation.xlSortColumns, _
    SortMethod:=Excel.XlSortMethod.xlPinYin, _
    DataOption1:=Excel.XlSortDataOption.xlSortTextAsNumbers

End Sub

Public Sub RenameItemFile()
  ' ワークシートの選択範囲(n行4列)の内容でファイル名を変更する
  '  1列目: 古いファイル名   --> oldfile
  '  2列目: 新しいファイル名 --> newfile
  '  3列目: 一時ファイル名   --> tmpfile
  '  4列目: フォルダ パス    --> C:\Users\xxxxx\Desktop\yyyyy

  Dim fso As Scripting.FileSystemObject
  Dim f As Scripting.File
  Dim rng As Excel.Range
  Dim folderPath() As String
  Dim fileNameOld() As String, filePathOld() As String
  Dim fileNameNew() As String, filePathNew() As String
  Dim fileNameTmp() As String, filePathTmp() As String
  Dim rngValue As Variant
  Dim N As Long
  Dim i As Long

  Set fso = New Scripting.FileSystemObject
  Set rng = Excel.Application.ActiveWindow.RangeSelection

  rngValue = rng.Areas(Index:=1)

  ' 単一セルの場合
  If Not VBA.Information.IsArray(rngValue) Then
    ReDim rngValue(1 To 1, 1 To 1)
  End If

  If UBound(rngValue, 2) <> ColNum.ColFolderPath Then
    VBA.Interaction.MsgBox _
      Prompt:= _
        "選択範囲は 4列 にしてください" & VBA.Constants.vbCrLf & _
        VBA.Constants.vbCrLf & _
        "選択範囲の例" & VBA.Constants.vbCrLf & _
        "1列目: 古いファイル名 --> oldfile.txt" & VBA.Constants.vbCrLf & _
        "2列目: 新しいファイル名 --> newfile.txt" & VBA.Constants.vbCrLf & _
        "3列目: 一時ファイル名 --> tmpfile.txt" & VBA.Constants.vbCrLf & _
        "4列目: フォルダ パス  --> C:\Users\xxxxx\Desktop\yyyyy" & VBA.Constants.vbCrLf & _
        VBA.Constants.vbCrLf & _
        "マクロを終了します", _
      Buttons:=VBA.VbMsgBoxStyle.vbOKOnly, _
      Title:="選択範囲は 4列 にしてください"
    Exit Sub
  End If

  N = UBound(rngValue, 1)

  ReDim fileNameOld(1 To N), filePathOld(1 To N)
  ReDim fileNameNew(1 To N), filePathNew(1 To N)
  ReDim fileNameTmp(1 To N), filePathTmp(1 To N)
  ReDim folderPath(1 To N)

  For i = 1 To N Step 1
    folderPath(i) = rngValue(i, ColNum.ColFolderPath)

    ' フォルダが存在しない場合
    If Not fso.FolderExists(FolderSpec:=folderPath(i)) Then
      Err.Raise _
        Number:=VBA.Constants.vbObjectError + 65535, _
        Description:= _
          "フォルダが存在しません" & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          "選択範囲 --> 行: " & i & ", 列: " & ColNum.ColFolderPath & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          folderPath(i)
    End If

    fileNameOld(i) = rngValue(i, ColNum.ColOldFileName)
    filePathOld(i) = fso.BuildPath(Path:=folderPath(i), Name:=fileNameOld(i))

    ' 古いファイルが存在しない場合
    If Not fso.FileExists(filePathOld(i)) Then
      Err.Raise _
        Number:=VBA.Constants.vbObjectError + 65535, _
        Description:= _
          "古いファイルが存在しません" & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          "選択範囲 --> 行: " & i & ", 列: " & ColNum.ColOldFileName & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          filePathOld(i)
    End If

    fileNameTmp(i) = rngValue(i, ColNum.ColTmpFileName)
    filePathTmp(i) = fso.BuildPath(Path:=folderPath(i), Name:=fileNameTmp(i))

    ' 一時ファイルが存在している場合
    If fso.FileExists(filePathTmp(i)) Then
      Err.Raise _
        Number:=VBA.Constants.vbObjectError + 65535, _
        Description:= _
          "既に一時ファイルが存在しています" & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          "選択範囲 --> 行: " & i & ", 列: " & ColNum.ColTmpFileName & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          filePathTmp(i)
    End If
  Next i

  ' filePathOld()の重複チェック無し
  ' filePathTmp()の重複チェック無し

  ' 古いファイル名を一時ファイル名に変更
  For i = 1 To N Step 1
    Set f = fso.GetFile(FilePath:=filePathOld(i))
    f.Name = fileNameTmp(i)
  Next i

  For i = 1 To N Step 1
    fileNameNew(i) = rngValue(i, ColNum.ColNewFileName)
    filePathNew(i) = fso.BuildPath(Path:=folderPath(i), Name:=fileNameNew(i))

    ' 新しいファイルが存在している場合
    If fso.FileExists(filePathNew(i)) Then
      Err.Raise _
        Number:=VBA.Constants.vbObjectError + 65535, _
        Description:= _
          "既に新しいファイルが存在しています" & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          "選択範囲 --> 行: " & i & ", 列: " & ColNum.ColNewFileName & VBA.Constants.vbCrLf & _
          VBA.Constants.vbCrLf & _
          filePathNew(i)
    End If
  Next i

  ' fileNameNew()の重複チェック無し

  ' 一時ファイル名を新しいファイル名に変更
  For i = 1 To N Step 1
    Set f = fso.GetFile(FilePath:=filePathTmp(i))
    f.Name = fileNameNew(i)
  Next i

End Sub