FSO フォルダ名変更指定文字を先頭に付加させる
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
Sub SetScrrunDLL() '***************************************************** 'このコードが実装されたブックが「FileSystemObject」 'が使えるように参照設定をする。 '***************************************************** On Error GoTo MyERROE: '参照設定 ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\system32\scrrun.dll" MyERROE: End Sub Sub フォルダ名変更() '***************************************************** '指定文字を先頭に付加(追加)させる '***************************************************** '対象は同階層フォルダ '結果を新しいシートを追加し一覧表示 Dim Fso As FileSystemObject Dim sht As Worksheet, Nsht As Worksheet Dim lIndex As Long Dim hFolder As Folder Dim subFolder As Folder Dim FukaName As String Dim MotoName As String Dim PathName As String Set Fso = New FileSystemObject Set hFolder = Fso.GetFolder(ThisWorkbook.Path & "\") Set sht = ThisWorkbook.Worksheets("Sheet1") Set Nsht = ThisWorkbook.Worksheets.Add PathName = ThisWorkbook.Path & "\" With sht FukaName = .Cells(2, 1).Value End With With Nsht .Cells.ClearContents lIndex = 0 lIndex = lIndex + 1 .Cells(lIndex, 1).Value = "Index" .Cells(lIndex, 2).Value = "旧名" .Cells(lIndex, 3).Value = "新名" For Each subFolder In hFolder.SubFolders lIndex = lIndex + 1 .Cells(lIndex, 1).Value = lIndex - 1 MotoName = subFolder.Name .Cells(lIndex, 2).Value = MotoName Set Fso = CreateObject("Scripting.FileSystemObject") 'フォルダの名前を変更 Fso.GetFolder(PathName & MotoName).Name = FukaName & MotoName Set Fso = Nothing .Cells(lIndex, 3).Value = FukaName & MotoName Next subFolder End With Set Fso = Nothing Set hFolder = Nothing Set sht = Nothing MsgBox "END" End Sub |