Доброго дня. Подскажите как правильно решить задачу. Существует таблица описывающая объекты, каждый объект идентифицируется уникальным номером, для каждого объекта имеется фотография, частью имени которой является этот номер, требуется по произвольной выборке уникальных номеров, заданных таблицей excel, найти все файлы в заданном каталоге и его подкаталогах, содержащие в имени этот номер и скопировать их в произвольный каталог.
Доброго дня. Подскажите как правильно решить задачу. Существует таблица описывающая объекты, каждый объект идентифицируется уникальным номером, для каждого объекта имеется фотография, частью имени которой является этот номер, требуется по произвольной выборке уникальных номеров, заданных таблицей excel, найти все файлы в заданном каталоге и его подкаталогах, содержащие в имени этот номер и скопировать их в произвольный каталог.Данилкин
Sub d() Dim f, i&, ii&, ar(), fol$, NewFol$ ar = [a2:a290].Value 'Selection.Value fol = [c2] NewFol = [d2] f = Enlist_Directories(fol) For i = 1 To UBound(ar) For ii = 0 To UBound(f) If f(ii) Like "*" & ar(i, 1) & "*" Then Copy_File f(ii), NewFol & Dir(f(ii)) Next ii, i End Sub Private Function Copy_File(ByVal sFileName As String, ByVal sNewFileName As String) As Boolean Dim objFSO As Object If sFileName = sNewFileName Then Exit Function If Dir(sFileName, 16) = "" Then: Exit Function If Not Dir(sNewFileName, 16) = "" Then Kill sNewFileName Set objFSO = CreateObject("Scripting.FileSystemObject") Call objFSO.CopyFile(sFileName, sNewFileName) Copy_File = True End Function Function Enlist_Directories(strPath As String) Dim strFldrList() As String Dim lngArrayMax, x As Long, lngSheet& lngSheet = 100 'As Long lngArrayMax = 0 strFn = Dir(strPath & "*.*", 23) While strFn <> ""
If Not (GetAttr(strPath & strFn) And vbDirectory) = vbDirectory Then lngArrayMax = lngArrayMax + 1 ReDim Preserve strFldrList(lngArrayMax) strFldrList(lngArrayMax) = strPath & strFn End If
strFn = Dir() Wend Enlist_Directories = strFldrList End Function
[/vba]
Так? : [vba]
Код
Sub d() Dim f, i&, ii&, ar(), fol$, NewFol$ ar = [a2:a290].Value 'Selection.Value fol = [c2] NewFol = [d2] f = Enlist_Directories(fol) For i = 1 To UBound(ar) For ii = 0 To UBound(f) If f(ii) Like "*" & ar(i, 1) & "*" Then Copy_File f(ii), NewFol & Dir(f(ii)) Next ii, i End Sub Private Function Copy_File(ByVal sFileName As String, ByVal sNewFileName As String) As Boolean Dim objFSO As Object If sFileName = sNewFileName Then Exit Function If Dir(sFileName, 16) = "" Then: Exit Function If Not Dir(sNewFileName, 16) = "" Then Kill sNewFileName Set objFSO = CreateObject("Scripting.FileSystemObject") Call objFSO.CopyFile(sFileName, sNewFileName) Copy_File = True End Function Function Enlist_Directories(strPath As String) Dim strFldrList() As String Dim lngArrayMax, x As Long, lngSheet& lngSheet = 100 'As Long lngArrayMax = 0 strFn = Dir(strPath & "*.*", 23) While strFn <> ""
If Not (GetAttr(strPath & strFn) And vbDirectory) = vbDirectory Then lngArrayMax = lngArrayMax + 1 ReDim Preserve strFldrList(lngArrayMax) strFldrList(lngArrayMax) = strPath & strFn End If
strFn = Dir() Wend Enlist_Directories = strFldrList End Function
SLAVICK, программа завершает работу ошибкой на первом цикле "For ii = 0 To UBound(f)", взглянете, я не вполне понимаю почему, пути на реальные заменил, файл прилагаю.
SLAVICK, программа завершает работу ошибкой на первом цикле "For ii = 0 To UBound(f)", взглянете, я не вполне понимаю почему, пути на реальные заменил, файл прилагаю.Данилкин
SLAVICK, по поводу первого столбца я так и понял, в папку DataBase я, на момент проверки работоспособности, запустил копирование файлов ~200GB и там что-то уже было, не факт, что с указанными в таблице уникальными номерами.
SLAVICK, по поводу первого столбца я так и понял, в папку DataBase я, на момент проверки работоспособности, запустил копирование файлов ~200GB и там что-то уже было, не факт, что с указанными в таблице уникальными номерами.Данилкин
Переделал немного. Прошлый пример смотрел только в строго указанную папку. Сейчас во всех вложенных подпапках тоже. Использовал часть кода отсюда
Переделал немного. Прошлый пример смотрел только в строго указанную папку. Сейчас во всех вложенных подпапках тоже. Использовал часть кода отсюдаSLAVICK
SLAVICK, спасибо), тестирую. После подстановки путей с старта, наблюдается некторая полуторачасовая задумчивость. но данных много, для поиска, ожидаю.
SLAVICK, спасибо), тестирую. После подстановки путей с старта, наблюдается некторая полуторачасовая задумчивость. но данных много, для поиска, ожидаю.Данилкин
- так и должно быть. Если эта процедура многоразовая можно добавить вывод в статусную строку сколько % выполнено. А если на один раз то и так сойдет SLAVICK
Иногда все проще чем кажется с первого взгляда.
Сообщение отредактировал SLAVICK - Вторник, 15.12.2015, 19:07
SLAVICK, спасибо! Прекрасно отработала! Да и не полтора часа, в первый раз долго было потому что я цифры короткие не убрал ну и файлов конечно нашлось много. А для того чтобы файлы не скопировать, а переместить в этих строчках кода нужно команду заменить? [vba]
Код
For i = 1 To UBound(ar) For ii = 1 To UBound(f) If f(ii) Like "*" & ar(i, 1) & "*" Then Copy_File f(ii), NewFol & Dir(f(ii)) Next ii, i End Sub
[/vba] [vba]
Код
Private Function Copy_File(ByVal sFileName As String, ByVal sNewFileName As String) As Boolean Dim objFSO As Object If sFileName = sNewFileName Then Exit Function If Dir(sFileName, 16) = "" Then: Exit Function If Not Dir(sNewFileName, 16) = "" Then Kill sNewFileName Set objFSO = CreateObject("Scripting.FileSystemObject") Call objFSO.CopyFile(sFileName, sNewFileName) Copy_File = True End Function
[/vba] [moder]Оформляйте коды тегами! Поправила на первый раз[/moder]
SLAVICK, спасибо! Прекрасно отработала! Да и не полтора часа, в первый раз долго было потому что я цифры короткие не убрал ну и файлов конечно нашлось много. А для того чтобы файлы не скопировать, а переместить в этих строчках кода нужно команду заменить? [vba]
Код
For i = 1 To UBound(ar) For ii = 1 To UBound(f) If f(ii) Like "*" & ar(i, 1) & "*" Then Copy_File f(ii), NewFol & Dir(f(ii)) Next ii, i End Sub
[/vba] [vba]
Код
Private Function Copy_File(ByVal sFileName As String, ByVal sNewFileName As String) As Boolean Dim objFSO As Object If sFileName = sNewFileName Then Exit Function If Dir(sFileName, 16) = "" Then: Exit Function If Not Dir(sNewFileName, 16) = "" Then Kill sNewFileName Set objFSO = CreateObject("Scripting.FileSystemObject") Call objFSO.CopyFile(sFileName, sNewFileName) Copy_File = True End Function
[/vba] [moder]Оформляйте коды тегами! Поправила на первый раз[/moder]Данилкин
Сообщение отредактировал Manyasha - Среда, 16.12.2015, 14:32
SLAVICK, доброго дня! Спасибо огроменское! Прога работает, все как надо выбирает, еще один небольшой ньюанс выявил в процессе эксплуатации, не всегда оказывается есть файлы, наличие которых в каталогах поиска ожидается, как в исходном файле отметить, какие части имен найдены, а какие нет, идеально - любую отметку в колонку рядом, также можно добавить что-то в содержащую часть имени ячейку. Поможете? Сам пока никак не дойду.
SLAVICK, доброго дня! Спасибо огроменское! Прога работает, все как надо выбирает, еще один небольшой ньюанс выявил в процессе эксплуатации, не всегда оказывается есть файлы, наличие которых в каталогах поиска ожидается, как в исходном файле отметить, какие части имен найдены, а какие нет, идеально - любую отметку в колонку рядом, также можно добавить что-то в содержащую часть имени ячейку. Поможете? Сам пока никак не дойду.Данилкин
Рад, что помогло Проще всего добавить массив такой же размерности и там отмечать количество найденных: [vba]
Код
Sub d() Dim f(), i&, ii&, ar(), ar1(), fol$, NewFol$, coll As Collection ar = [a2:a2471].Value 'Selection.Value ReDim ar1(1 To UBound(ar), 1 To 1) fol = [c2] NewFol = [d2] Set coll = FilenamesCollection(fol) ReDim f(1 To coll.Count) For ii = 1 To coll.Count f(ii) = coll(ii) Next For i = 1 To UBound(ar) For ii = 1 To UBound(f) If f(ii) Like "*" & ar(i, 1) & "*" Then Copy_File f(ii), NewFol & Dir(f(ii)): ar1(i, 1) = ar1(i, 1) + 1 Next ii, i [b2].Resize(UBound(ar1), 1) = ar1 End Sub
[/vba]
Рад, что помогло Проще всего добавить массив такой же размерности и там отмечать количество найденных: [vba]
Код
Sub d() Dim f(), i&, ii&, ar(), ar1(), fol$, NewFol$, coll As Collection ar = [a2:a2471].Value 'Selection.Value ReDim ar1(1 To UBound(ar), 1 To 1) fol = [c2] NewFol = [d2] Set coll = FilenamesCollection(fol) ReDim f(1 To coll.Count) For ii = 1 To coll.Count f(ii) = coll(ii) Next For i = 1 To UBound(ar) For ii = 1 To UBound(f) If f(ii) Like "*" & ar(i, 1) & "*" Then Copy_File f(ii), NewFol & Dir(f(ii)): ar1(i, 1) = ar1(i, 1) + 1 Next ii, i [b2].Resize(UBound(ar1), 1) = ar1 End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
