Найти названия файлов из Excel

[АLексаNдр]

Всем привет.
Хочу жене облегчить работу, а именно:

Есть Excel файл например со столбцом:
1
2
4
5
6
9
10

И есть папка с десятью файлами D:\Foto\*.jpeg, названия которых
1.jpeg; 2.jpeg; 3.jpeg; ..... 9.jpeg; 10.jpeg;

Так вот!!! Есть ли такая возможность, чтобы при нажатии кнопки в Excel(возможно сделанного модного макроса) он выбирал файлы из папки
D:\Foto\ и копировал только нужные (те, которые в столбце Excel) в папку, например D:\Foto\1\

P.S. просто это пример. а на самом деле файлов через день порядка 1500-2000 тысячи и она сидит и около часа выбирает. Заранее спасибо за любую помощь.

[valerij]

Сообщение от АLексаNдр

P.S. просто это пример. а на самом деле файлов через день порядка 1500-2000 тысячи и она сидит и около часа выбирает. Заранее спасибо за любую помощь.

Ни какой Excel, не сравнится с спец. прогай:
Picasa - программа-органайзер ваших фотографий и видеоматериалов. Это программное обеспечение, с помощью которого Вы можете искать, просматривать, редактировать, печатать фотографии и обмениваться ими, превращать фотографии в "фильм" или коллаж, создавать слайд-шоу и многое другое.
-Программа сканирует весь винчестер или указанные пользователем папки, индексирует все фотографии, графику и видео файлы, сортирует их в визуальные альбомы, упорядоченные по датам, так что потеряться ни одной картинке не удастся..........

[АLексаNдр]

Дело в том, что я не ищу какой-то органайзер для личной коллекции фоток. Жена моя - фотограф. И к ней когда приходит заказ на 900 фоток из 1200, то надо выбрать эти 900 и сделать. Поэтому я думаю что эта програмулина мне не подойдет. Хотя все равно спасибо. Сейчас скачаю и ознакомлюсь....

P.S. А по поводу Excel нет пока вариантов?

[EducatedFool]

Sub Move_JPEG_Photoes()
    Const SourceFolder = "C:\Documents and Settings\Администратор\Рабочий стол\Исходная папка\"
    Const DestinationFolder = "C:\Documents and Settings\Администратор\Рабочий стол\Результат\"

    On Error Resume Next
    If Dir(DestinationFolder, vbDirectory) = "" Then MkDir DestinationFolder

    Dim ce As Range
    For Each ce In Selection.Cells
        Filename = Trim$(ce.Value)
        If Len(Filename) > 0 Then
            If InStr(1, Filename, ".jp") = 0 Then Filename = Filename & ".jpeg"
            If Dir(SourceFolder & Filename) <> "" Then
                Application.StatusBar = "Перемещение файла  " & Filename
                Name SourceFolder & Filename As DestinationFolder & Filename
                DoEvents
                If Dir(DestinationFolder & Filename) <> "" Then ce.Interior.Color = vbGreen
            End If
        End If
    Next
    Application.StatusBar = ""
End Sub

Измените значения констант SourceFolder и DestinationFolder на нужные Вам значения. Не забудьте про последний символ "\" в имени папки.
Для приведённого Вами примера первые 2 строки макроса будут иметь вид:
Const SourceFolder = "D:\Foto\"
Const DestinationFolder = "D:\Foto\1\"


После этого выделите диапазон ячеек, содержащих имена файлов, и запустите этот макрос.
Если папки DestinationFolder не существует, она будет создана.

Макрос перемещает указанные файлы (из одной папки в другую), а не копирует их - так получается намного быстрее (если, конечно, папки SourceFolder и DestinationFolder расположены на одном диске).

При желании по окончании работы макроса можно вручную выделить все файлы в папке DestinationFolder, и скопировать их в SourceFolder. Конечно же, это легко реализуется и в макросе (если нужно).

Ячейки, содержащие имена файлов, которые удалось успешно переместить, будут окрашены в зелёный цвет.


PS: В принципе, несложно организовать запрос у пользователя расположения исходной и конечной папок, а также диапазона ячеек, содержащих имена файлов. Так же можно перемещать \ копировать только файлы определённых типов (например, jpeg). Если это надо, опишите задание более подробно.

[АLексаNдр]

Супер!!! спасибо. только вот вопрос первый. Где тот момент, в котором написано копировать либо вырезать (я хочу чтобы оно всетаки копировались)? И втором момент. Можно ли чтобы при нажатии кнопки макоса он спрашивал на какую папку "смотреть" и в какую копировать? Просто каждый раз это разные папки и изменять макрос не сильно хочется.

[EducatedFool]

Перемещение файла производится строкой
Name SourceFolder & Filename As DestinationFolder & Filename

Точнее, файл переименовывается из "D:\Foto\1.gpeg" в "D:\Foto\1\1.gpeg", то есть фактически происходит перемещение файла из одной папки в другую.

Чтобы производилось копирование, замените строку

Name SourceFolder & Filename As DestinationFolder & Filename

на строку

FileCopy SourceFolder & Filename, DestinationFolder & Filename

Можно ли чтобы при нажатии кнопки макоса он спрашивал на какую папку "смотреть" и в какую копировать?

Можно. В ближайшее время сделаю.
Выбор папки будет производится примерно так:

Sub test()
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count > 0 Then MsgBox .SelectedItems(1)
End With
End Sub

[АLексаNдр]

Все ок. Тоько есть две проблемы:

1) Названия файлов в папке всегда такие 0000.jpeg; 0001.jpeg. Т.е. четыре знака.
Когда в Excel пишу 1, 2, 3 и т.д. либо 0001, 0002, 0003 (нули высвечиваются только при формате ячеек "табельный"). а файлы назваются 1, 2, 3, то все работает. Но стоит мне файлы переименовать на 0001, 0002, 0003 (как должно быть) - НИЧЕГО не получается.
2) Последний код я немогу правильно прикрутить к существующему коду. Он меня спрашивает какую папку выбрать и все.

Огромное спасибо за помощь!!!!

[АLексаNдр]

" Названия файлов в папке всегда такие 0000.jpeg; 0001.jpeg. Т.е. четыре знака.
Когда в Excel пишу 1, 2, 3 и т.д. либо 0001, 0002, 0003 (нули высвечиваются только при формате ячеек "табельный"). а файлы назваются 1, 2, 3, то все работает. Но стоит мне файлы переименовать на 0001, 0002, 0003 (как должно быть) - НИЧЕГО не получается."

вопрос снимается. сам нашел. Спасибо...

А вот п поводу выбора папки еще очень надо.....

[EducatedFool]

Попробуйте такой код:

Sub Move_JPEG_Photoes_New()
    Dim SourceFolder As String, DestinationFolder As String, ce As Range
    Const InitialPath = "D:\Foto\"

    SourceFolder = GetFolderPath("Выберите исходную папку для поиска файлов", InitialPath)
    If SourceFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    DestinationFolder = GetFolderPath("Выберите папку, в которую будет производиться копирование", SourceFolder)
    If DestinationFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub

    On Error Resume Next
    If Dir(DestinationFolder, vbDirectory) = "" Then MkDir DestinationFolder    ' если конечная папка не существует, создаём её

    For Each ce In Selection.Cells
        Filename = Trim$(ce.Value)
        If Len(Filename) > 0 Then
            ' если в ячейке указано имя файла без расширения, то добавляем его
            If InStr(1, Filename, ".jp") = 0 Then Filename = Filename & ".jpeg"

            If Dir(SourceFolder & Filename) <> "" Then    'если файл с таким именем найден в исходной папке
                Application.StatusBar = "Перемещение файла  " & Filename    ' вывод информации в строку состояния
                ' Name SourceFolder & Filename As DestinationFolder & Filename   ' перемещение
                FileCopy SourceFolder & Filename, DestinationFolder & Filename  ' копирование
                DoEvents
                ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen)    ' окраска ячеек
            End If
        End If
    Next
    Application.StatusBar = ""
End Sub

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

В строке Const InitialPath = "D:\Foto\" вместо "D:\Foto\" можно указать путь к папке, с которой будет начинаться обзор компьютера (в диалоговом окне выбора исходной папки)

нули высвечиваются только при формате ячеек "табельный"

Не знаю, что такое "табельный" формат, но если ячейке предварительно назначен текстовый формат, то в ячейки легко можно вводить строки типа 0001.

Кроме того, вместо изменения формата ячейки, Вы можете перед набором цифр ввести ' (одинарную кавычку), то есть, набрав '0002, в ячейке Вы получите текст 0002.

[АLексаNдр]

По поводу нулей я уже разобрался. Спасибо.
По поводу последнего кода он вроде немного не работает, но я из всех слепил один и он прекрасно работает. Огромны респект умным людям

Вот, кстати. а что означала эта функция?

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
    GetFolderPath = "": PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show = -1 Then GetFolderPath = .SelectedItems(1): If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function

У меня без нее все работает....

И еще... Это как дополнительный вопрос:

К этому получившемуся зверю хочу добавить еще одну маленькую примочку. а именно:
Excel
В Столбце "А" номера фоток 0001, 0003, 0008, 0020
В Столбце "B" их колличесвто 1, 4, 2, 2 соответсвенно

Теперь сам вопрос: Как написать отдельный макрос (я его прикручу на отдельную кнопку) чтобы при нажатии он копировал 0001 в папку 1, 0003 в папку 4, 0008 и 0020 в папку 2.
Условимся что файлы лежат в папке, которую опять же надо выбрать, а вот папки с колличеством фоток создавались бы сами в папке где лежат оригиналы.

Ух закрутил. Я даже незнаю как и благодарить за такую работу. Спасибо.