Есть столбец с названиями фото (5000+) и папка в которой по подпапкам разложены эти фото. Нужно найти в этой папке фото по названию и выдать в столбце путь к фото. (|Имя_файла| |С:\Фото\*бла-бла случайное*\Имя_Файла|), вложенность до двух. Я нашел готовый пример:
Код
'---------------------------------------------------------------------------------------
' Модуль : modFilenames
' Автор : EducatedFool (Игорь) Дата: 13.04.2011
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' http://excelvba.ru/ ICQ: 5836318 Skype: ExcelVBA.ru
' Реквизиты для оплаты: http://excelvba.ru/payments
'---------------------------------------------------------------------------------------
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 ' перебираем все элементы коллекции, содержащей пути к файлам
ИмяФайла = Dir(ПутьКФайлу)
' выводим на лист очередную строку
Range("a" & Rows.Count).End(xlUp).Offset(1).Resize(, 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).ClearContents
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.FileSystemObject") ' создаём экземпляр 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
Next
End If
Set fil = Nothing: Set curfold = Nothing ' очищаем переменные
End If
End Function
Но он "одноразовый" и не умеет идти вниз по списку и работает в форме. К тому же фото соответствующее названию будет только одно (если не увеличивать вложенность до 3-х, там есть дубли меньшего размера) а скрипт создан для поиска всех файлов по маске. Я в ВБА полный ноль, но фотки эти перебирать вечность буду.
Понимаю что задача из разряда "сделайте все за меня", но ситуация патовая. Суммарно. прошу помочь составить скрипт который будет брать готовое название фото из списка, искать файл с этим названием в заранее известной папке, и выдавать в соседнюю ячейку путь к этому фото, не углубляясь далее 2-го уровня вложенности. Заранее благодарю!)
Изменено: shelomitsky2011 - 22.09.2022 12:47:26(Дополнено без воды)