Sub ReplaceFolderNames()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim folderPath As String, searchName As String, replaceName As String
Dim folder As Object, fso As Object
Set ws = ThisWorkbook.Sheets(1) ' 1番目のシートを使用
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' A列の最終行を取得
Set fso = CreateObject("Scripting.FileSystemObject")
folderPath = ThisWorkbook.Path ' ThisWorkbookがあるフォルダのパス
' 2行目から最終行までループ
For i = 2 To lastRow
searchName = ws.Cells(i, 1).Value ' A列の値（検索文字列）
replaceName = ws.Cells(i, 2).Value ' B列の値（置換文字列）
' フォルダ名の置換を試みる
If fso.FolderExists(folderPath & "\" & searchName) Then
Set folder = fso.GetFolder(folderPath & "\" & searchName)
Name folder.Path As folderPath & "\" & replaceName
End If
Next i
Set fso = Nothing
MsgBox "Folder names have been replaced."
End Sub
