フォルダのリネーム

Sub prcRenameFolders()
    Dim lngRowStart As Long      ' 処理開始行
    Dim lngRowEnd As Long        ' 処理終了行
    Dim lngRow As Long           ' 現在処理中の行
    Dim strParentPath As String  ' 親フォルダのパス
    Dim strCurrentName As String ' 現在のフォルダ名
    Dim strNewName As String     ' 新しいフォルダ名
    Dim fso As FileSystemObject  ' ファイルシステムを操作するオブジェクト
    Dim fld As Folder            ' 操作対象のフォルダオブジェクト
    Dim strFullPath As String    ' 現在のフルパス
    Dim wst As Worksheet         ' 操作対象のワークシート

    ' FileSystemObjectのインスタンスを生成
    Set fso = New FileSystemObject
    ' 操作対象のシートをセット
    Set wst = ThisWorkbook.Sheets("Sheet1")

    ' wstを利用して処理を行う
    With wst
        ' 処理開始行と最終行を設定
        lngRowStart = 2
        lngRowEnd = .Cells(.Rows.Count, "B").End(xlUp).Row

        ' 指定した行範囲でループ処理
        For lngRow = lngRowStart To lngRowEnd
            strParentPath = .Cells(lngRow, "B").Value
            strCurrentName = .Cells(lngRow, "C").Value  ' C列の値
            strNewName = .Cells(lngRow, "D").Value      ' D列の値

            ' 現在のフルパスを生成
            strFullPath = fso.BuildPath(strParentPath, strCurrentName)
            ' フォルダが存在するかチェック
            If fso.FolderExists(strFullPath) Then
                ' 新しいフルパスを生成
                Set fld = fso.GetFolder(strFullPath)
                ' フォルダ名を変更
                fld.Name = strNewName
            Else
                Debug.Print "フォルダが存在しません: " & strFullPath
            End If
        Next lngRow
    End With

    ' オブジェクトの解放
    Set fld = Nothing
    Set fso = Nothing
    Set wst = Nothing
End Sub