FSO フォルダ名変更指定文字を先頭に付加させる

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit


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

 

2000年01月01日|[VBサンプルコード]:[FSO]