переименование файлов в папке макросом из Excel

[fosters91]

Добрый день!
данная тема уже обсуждалась на этом форруме (ссылка ниже), но у меня не получается написать корректный макрос.

http://www.programmersforum.ru/showt...t=60191&page=2


Добры, у меня похожа проблема. у меня есть в колонке скажем B:B гиперссылки на файлы которые у меня на компе. Можно переделать макрос этот, чтоб он переименовывал сами файлы на компе исходя из данных в колонке C, D (необходимо, чтобы текст в колонках объединялся через нижнее подчёркивание "_") и менял гиперссылку на переименованный файл.

Заранее спасибо!

[Казанский]

Пробуйте

Sub bb()
Dim c As Range, f$, g$
  For Each c In Range("B2", Cells(Rows.Count, "B").End(xlUp))
    f = c.Hyperlinks(1).Address
    If Dir(f) <> "" Then
      g = c(, 2) & "_" & c(, 3) & Mid$(f, InStrRev(f, "."))
      Name f As g
      c.Hyperlinks(1).Address = g
      c.Hyperlinks(1).TextToDisplay = g
    End If
  Next
End Sub

[fosters91]

Добрый день!
попробовал- не получается.

можешь показать, как полностью выглядит код, в общем макросе?

[Казанский]

Что именно не получается - не переименовывает или сообщение об ошибке появляется?
Это код полностью. Предполагается, что файлы находятся в той же папке, что и книга с макросом (по Ctrl+K не видно какого-либо пути).
Зачем эти иконки PDF - непонятно.

[fosters91]

не переименовывает. сообщения об ошибке нет.
файлы ПДФ для примера (типа они лежат в этой же папке)

[fosters91]

Sub ЗагрузкаСпискаФайлов()
' Ищем файлы в заданной папке по заданной маске,
' и выводим на лист список их параметров.
' Просматриваются папки с заданной глубиной вложения.

Dim coll As Collection, ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%

ПутьКПапке$ = [c1] ' берём из ячейки c1
МаскаПоиска$ = [c2] ' берём из ячейки c2
ГлубинаПоиска% = Val([c3]) ' берём из ячейки c3
If ГлубинаПоиска% = 0 Then ГлубинаПоиска% = 999 ' без ограничения по глубине

' считываем в колекцию coll нужные имена файлов
Set coll = FilenamesCollection(ПутьКПапке$, МаскаПоиска$, ГлубинаПоиска%)

Application.ScreenUpdating = False ' отключаем обновление экрана

' выводим результаты (список файлов, и их характеристик) на лист
For i = 1 To coll.Count ' перебираем все элементы коллекции, содержащей пути к файлам

НомерФайла = i
ПутьКФайлу = coll(i)
ИмяФайла = Dir(ПутьКФайлу)
ДатаСоздания = FileDateTime(ПутьКФайлу)
РазмерФайла = FileLen(ПутьКФайлу)

' выводим на лист очередную строку
Range("a" & Rows.Count).End(xlUp).Offset(1).Res ize(, 5).Value = _
Array(НомерФайла, ИмяФайла, ПутьКФайлу, ДатаСоздания, РазмерФайла)

' если нужна гиперссылка на файл во втором столбце
ActiveSheet.Hyperlinks.Add Range("b" & Rows.Count).End(xlUp), ПутьКФайлу, "", _
"Открыть файл" & vbNewLine & ИмяФайла

DoEvents ' временно передаём управление ОС
Next
End Sub

Sub ОчисткаСписка()
On Error Resume Next
Intersect(Rows("6:" & Rows.Count), ActiveSheet.UsedRange).ClearContent s
End Sub

' ===================== код функции ===========================
Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
Optional ByVal SearchDeep As Long = 999) As Collection
' Получает в качестве параметра путь к папке FolderPath,
' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
' Возвращает коллекцию, содержащую полные пути найденных файлов
' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

Set FilenamesCollection = New Collection ' создаём пустую коллекцию
Set FSO = CreateObject("Scripting.FileSystemO bject") ' создаём экземпляр FileSystemObject
GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
Set FSO = Nothing: Application.StatusBar = False ' очистка строки состояния Excel
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
' перебор папок осуществляется в том случае, если SearchDeep > 1
' добавляет пути найденных файлов в коллекцию FileNamesColl
On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
If Not curfold Is Nothing Then ' если удалось получить доступ к папке

' раскомментируйте эту строку для вывода пути к просматриваемой
' в текущий момент папке в строку состояния Excel
Application.StatusBar = "Поиск в папке: " & FolderPath

For Each fil In curfold.Files ' перебираем все файлы в папке FolderPath
If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
Next
SearchDeep = SearchDeep - 1 ' уменьшаем глубину поиска в подпапках
If SearchDeep Then ' если надо искать глубже
For Each sfol In curfold.SubFolders ' ' перебираем все подпапки в папке FolderPath
GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep

Set fil = Nothing: Set curfold = Nothing ' очищаем переменные
End If
Sub bb()
Dim c As Range, f$, g$
For Each c In Range("B2", Cells(Rows.Count, "B").End(xlUp))
f = c.Hyperlinks(1).Address
If Dir(f) <> "" Then
g = c(, 2) & "_" & c(, 3) & Mid$(f, InStrRev(f, "."))
Name f As g
c.Hyperlinks(1).Address = g
c.Hyperlinks(1).TextToDisplay = g
End If
Next
End Sub

[Aleksandr H.]

Лучше бы файла приложили или же код отформатировали, иначе - "многа букафф, ниасилил"

[fosters91]

файл загрузил