Sub RenameFoldersInFolders()
Dim parentFolderPath As String
Dim fso As Object
Dim parentFolder As Object
Dim subFolder As Object
Dim newFolderName As String
Dim counter As Integer
' Укажите путь к родительской папке, в которой находятся подпапки
parentFolderPath = "R:\ххххх\_Новая\ПАПКА" ' Измените на путь к вашей родительской папке
' Создаем объект FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")
' Проверяем, существует ли родительская папка
If Not fso.FolderExists(parentFolderPath) Then
MsgBox "Родительская папка не найдена!"
Exit Sub
End If
' Открываем родительскую папку
Set parentFolder = fso.GetFolder(parentFolderPath)
' Счетчик для создания уникальных имен
counter = 1
' Перебираем все подпапки в родительской папке
For Each subFolder In parentFolder.Subfolders
' Пример нового имени папки: "Folder_1", "Folder_2" и так далее
' newFolderName = "Folder_" & counter
CurentName = subFolder.Name
newName = Replace(CurentName, "++", "")
If subFolder.Name <> newName Then subFolder.Name = newName
' Переименовываем папку
' Name parentFolderPath & CurentName as & "\" & newFolderName
' subFolder = parentFolderPath & "\" & newFolderName
' Увеличиваем счетчик
counter = counter + 1
Next subFolder
MsgBox "Переименование папок завершено!"
End Sub