【VBA】リネームする
面白そうだったのでチャレンジしてみました。
暇なVBAerに課題置いておきます。
— ことりちゅん@えくせるちゅんちゅん (@KotorinChunChun) 2021年4月4日
a列のファイル名を、ランダムに並び替えた結果をb列に出力した後、aからbのファイル名に一括変更するマクロを書いてみてください。
さらに、変更後にミスを発見したときの為に、元のファイル名に戻すマクロも書いてください。
なかなか楽しいですよ。
ワークシートはこんな感じ
[標準モジュール] Option Explicit Const CL_CHK As Long = 3 Public Sub Click_ランダムソート() Dim r As Long Dim lastRow As Long Dim destRow As Long lastRow = Cells(Rows.Count, 1).End(xlUp).Row Range(Cells(2, 2), Cells(lastRow, 2)).ClearContents Randomize For r = 2 To lastRow Do destRow = Int((lastRow - 2 + 1) * Rnd + 2) Loop Until Cells(destRow, 2).Value = "" Cells(destRow, 2).Value = Cells(r, 1).Value Next End Sub Public Sub Click_リネーム() Dim folderPath As String folderPath = "C:\Users\xxxx\Desktop\rename\files" Columns(CL_CHK).ClearContents Call renameFiles(folderPath, 1, 2) Columns(CL_CHK).ClearContents End Sub Public Sub Click_ファイル名を戻す() Dim folderPath As String folderPath = "C:\Users\xxxx\Desktop\rename\files" Columns(CL_CHK).ClearContents Call renameFiles(folderPath, 2, 1) Columns(CL_CHK).ClearContents End Sub Private Sub renameFiles(ByRef folderPath As String, _ ByRef colSource As Long, ByRef colDest As Long) Dim cnt As Long '処理済みカウント Dim cntFiles As Long '処理対象ファイル数 Dim r As Long Dim lastRow As Long Dim bufFileName As String 'ファイル名退避用 Dim srcFileName As String 'リネーム前のファイル名 Dim destFileName As String 'リネーム後のファイル名 '一時ファイル名 '何らかの処理で使われていないファイル名にする必要があるが、 '今回は簡単のため temp.txt とした Const TMP_FNAME As String = "temp.txt" lastRow = Cells(Rows.Count, colSource).End(xlUp).Row cntFiles = lastRow - 1 cnt = 0 Do r = 2 '未処理ファイル名の最初のものを temp.txt にリネームする '元のファイル名を bufFileName に格納する Do If Cells(r, CL_CHK).Value = "" Then bufFileName = Cells(r, colSource).Value Call renameFile(folderPath, bufFileName, TMP_FNAME) Exit Do End If r = r + 1 Loop destFileName = bufFileName Do 'リネーム後のファイル名のある行を探す r = getRow(destFileName, colDest, lastRow) If Cells(r, colSource).Value <> bufFileName Then 'その行にある元のファイル名が bufFileName でなかったら 'その行の元のファイル名をリネームして 'destFileName に元のファイル名を格納する srcFileName = Cells(r, colSource).Value Call renameFile(folderPath, srcFileName, destFileName) Cells(r, CL_CHK).Value = 1 destFileName = srcFileName cnt = cnt + 1 Else '元のファイル名が bufFileName と同じなら 'temp.txt としていたファイルをリネームして '一連の処理を終了し、再度先頭から未処理ファイル名のものを処理する Call renameFile(folderPath, TMP_FNAME, Cells(r, colDest).Value) Cells(r, CL_CHK).Value = 1 cnt = cnt + 1 Exit Do End If Loop Loop While cnt < cntFiles End Sub Private Sub renameFile(ByRef folderPath As String, _ ByRef srcFileName As String, ByRef destFileName As String) Dim fso As Object Dim f As Object Set fso = CreateObject("Scripting.FilesystemObject") Set f = fso.GetFile(folderPath & "\" & srcFileName) f.Name = destFileName Set f = Nothing Set fso = Nothing End Sub Private Function getRow(ByRef fileName As String, _ ByRef colTarget As Long, ByRef lastRow As Long) As Long Dim r As Long For r = 2 To lastRow If Cells(r, colTarget).Value = fileName Then getRow = r Exit For End If Next End Function