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 cntdel As Long
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
    cntdel = .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 = Mid(MotoName, cntdel + 1)
            Set Fso = Nothing

            .Cells(lIndex, 3).Value = Mid(MotoName, cntdel + 1)
        Next subFolder
End With

Set Fso = Nothing
Set hFolder = Nothing
Set sht = Nothing

MsgBox "END"
End Sub

 

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