Найти названия файлов из Excel - Microsoft Office Excel - Страница 2

EducatedFool · 07.11.2008, 17:48

Цитата:

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

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", Optional ByVal InitialPath As String = "c:\") As String
GetFolderPath = "": PS = Application.PathSeparator
With Application.FileDialog(msoFileDialo gFolderPicker)
.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

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

Очень бы хотел посмотреть, как может работать код из последнего поста (#9) без этой функции.

Эта функция отображает диалоговое окно выбора папки, и если пользователь выбрал какую-нибудь папку, функция возвращает путь к выбранной папке; а если отказался от выбора, то функция возвращает пустую строку.

Цитата:

По поводу последнего кода он вроде немного не работает

Как это немного не работает? Что именно не работает?

Должны появляться 2 диалога выбора папок (исходной и конечной), после чего происходит копирование нужных файлов из одной папки в другую. Ячейки с именами файлов, которые успешно скопировались, окрашиваются в зелёный цвет, а с именами файлов, копирование которых по каким-то причинам не удалось - в красный.

Цитата:

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

Сделаю в ближайшее время.

Цитата:

но я из всех слепил один и он прекрасно работает

Хотелось бы взглянуть на Ваш код.

АLексаNдр · 07.11.2008, 18:14

Код:

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

    DestinationFolder = GetFolderPath("Выберите папку, в которую будет производиться копирование", SourceFolder)
    If DestinationFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub
    
    ' Const SourceFolder = "Z:\30.08.08 Дима + Лена\JPEG\"
    ' Const DestinationFolder = "Z:\30.08.08 Дима + Лена\Выбранное программой\"

    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 & ".jpg"
            If Dir(SourceFolder & Filename) <> "" Then
                Application.StatusBar = "Перемещение файла  " & Filename
                FileCopy SourceFolder & Filename, DestinationFolder & Filename
                DoEvents
                If Dir(DestinationFolder & Filename) <> "" Then ce.Interior.Color = vbGreen
            End If
        End If
    Next
    Application.StatusBar = ""
End Sub

и все работает на отлично

Но в красный цвет не окрашивает. т.к. вторая часть кода была взята из предущей версии. но и так супер. (просто не хочется напрягать по пустякам).

А не работает следующее: он спрашивает откуда "смотреть" и куда копировать и все. СТОП!!! Молчит. Он просто не продолжает работать при выборе папок.
Это при коде из #9. Вот так

АLексаNдр · 07.11.2008, 18:29

виноват. функция "Function GetFolderPath..." была прописана во втором модуле. Сейчас я все скопировал в один модуль и все по прежнему работает.

Код:

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

    DestinationFolder = GetFolderPath("Выберите папку, в которую будет производиться копирование", SourceFolder)
    If DestinationFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub
    
    ' Const SourceFolder = "Z:\30.08.08 Дима + Лена\JPEG\"
    ' Const DestinationFolder = "Z:\30.08.08 Дима + Лена\Выбранное программой\"

    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 & ".jpg"
            If Dir(SourceFolder & Filename) <> "" Then
                Application.StatusBar = "Перемещение файла  " & 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

Только вот сделал строчку (скопировал сделанную Вами

)
ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen) вместо If Dir(DestinationFolder & Filename) <> "" Then ce.Interior.Color = vbGreen и она в красный цвет не окрашиватеся. но это не столь важно.

EducatedFool · 07.11.2008, 18:31

Цитата:

Но в красный цвет не окрашивает. т.к. вторая часть кода была взята из предущей версии.

Замените строку

If Dir(DestinationFolder & Filename) <> "" Then ce.Interior.Color = vbGreen

на строку

ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen) ' окраска ячеек

Цитата:

он спрашивает откуда "смотреть" и куда копировать и все. СТОП!!! Молчит. Он просто не продолжает работать при выборе папок.

Сейчас проверю. Код из 9 поста я не испытывал, так что возможны ошибки...

АLексаNдр · 07.11.2008, 18:49

Вот вырезка из кода

Код:

   
                   ......           
                DoEvents
                ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen) ' окраска ячеек
             End If

.....
В красный цвет не перекрашивается. Сделаные файлы становятся зелеными. А тех, которых не существует - остаются белыми.

EducatedFool · 07.11.2008, 19:19

Цитата:

В красный цвет не перекрашивается.

Замените код

Код:

If Dir(SourceFolder & Filename) <> "" Then
    Application.StatusBar = "Перемещение файла  " & Filename
    FileCopy SourceFolder & Filename, DestinationFolder & Filename
    DoEvents
    ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen)                ' окраска ячеек
End If

на код

Код:

If Dir(SourceFolder & Filename) <> "" Then
    Application.StatusBar = "Перемещение файла  " & Filename
    FileCopy SourceFolder & Filename, DestinationFolder & Filename
    DoEvents
End If
ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen)                ' окраска ячеек

То есть надо переместить строку ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen) на 1 строку ниже.

Цитата:

он спрашивает откуда "смотреть" и куда копировать и все. СТОП!!! Молчит. Он просто не продолжает работать при выборе папок.

Проверил. Всё работает.

PS: Для очистки цвета выделенных ячеек перед началом копирования
добавьте строку

Selection.Cells.Interior.ColorIndex = 0

перед строкой

For Each ce In Selection.Cells

АLексаNдр · 07.11.2008, 19:34

супер. Цвета работают. и очистка цвета работает. Итого с таким кодом:

Код:

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

    DestinationFolder = GetFolderPath("Выберите папку, в которую будет производиться копирование", SourceFolder)
    If DestinationFolder = "" Then MsgBox "Необходимо указать папку!", vbCritical, "Папка не выбрана": Exit Sub
    
    ' Const SourceFolder = "Z:\30.08.08 Дима + Лена\JPEG\"
    ' Const DestinationFolder = "Z:\30.08.08 Дима + Лена\Выбранное программой\"

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

    Dim ce As Range
    Selection.Cells.Interior.ColorIndex = 0
    For Each ce In Selection.Cells
        Filename = Trim$(ce.Value)
        If Len(Filename) > 0 Then
            If InStr(1, Filename, ".jp") = 0 Then Filename = Filename & ".jpg"
            If Dir(SourceFolder & Filename) <> "" Then
                Application.StatusBar = "Перемещение файла  " & Filename
                FileCopy SourceFolder & Filename, DestinationFolder & Filename
                DoEvents
                End If
        End If
        ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen) ' окраска ячеек
    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

А по поводу перемещение файлов в папку в зависимости от их колличества

EducatedFool · 07.11.2008, 20:04

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

Код:

Sub Copy_Photoes_Into_Different_Folders()

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

    'Const SourceFolder = "C:\Documents and Settings\Администратор\Рабочий стол\Исходная папка\"

    On Error Resume Next
    Dim ce As Range:    Selection.Cells.Interior.ColorIndex = 0
    
    For Each ce In Selection.Cells
        Filename = Trim$(ce.Value)
        If Len(Filename) > 0 Then
            If InStr(1, Filename, ".jp") = 0 Then Filename = Filename & ".jpg"

            If Dir(SourceFolder & Filename) <> "" Then
                c2 = Trim$(ce.Offset(, 1).Value)
                If Len(c2) > 0 Then ' если справа от имени файла пустая ячейка, то ничего не делаем
                    DestinationFolder = SourceFolder & c2 & Application.PathSeparator ' формируем новый путь для файла
                    If Dir(DestinationFolder, vbDirectory) = "" Then MkDir DestinationFolder ' если такой папки не существует, создаём её
                    Application.StatusBar = "Копирование файла  " & Filename & "  в папку  " & DestinationFolder
                    FileCopy SourceFolder & Filename, DestinationFolder & Filename ' копирование файла
                    DoEvents
                End If
            End If
            ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbYellow, vbGreen)        ' окраска ячеек
        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

Выделяем по-прежнему только ячейки одного столбца - те, в которых находятся имена файлов.

Если в ячейке справа от имени файла введено какое-либо значение, файл будет скопирован в соответствующую папку.

Обратите внимание, что некоторые символы нельзя использовать в именах файлов и папок, так что если в ячейках справа будут значения, содержащие символы типа *\/ и т.п., копирования не произойдёт.

АLексаNдр · 07.11.2008, 21:09

Супер. получилось. Т.е. название ячейки справа от имени это и есть название папки? Супер. Спасибо. Теперь у жены уйдет меньше времени на работу, но больше на меня... Вы даже не представляете как помогли. Спасибо.

P.S. Если что, то я еще постучусь? Ок?

ZORRO2005 · 09.11.2008, 05:10

АLексаNдр, EducatedFool, извиняюсь, что не создал новую тему,но продолжая эту тему, будет легче понять, что я хочу

EducatedFool , можно ли сделать следующее? …
В SourceFolder лежат файлы, которые мне надо переименовать и положить в DestinationFolder.
В столбце A будет список файлов из SourceFolder без расширения (могут быть как jpeg ,bmp так и xls,xlsx…).
В столбце B будут соответственно их новые названия без расширения (расширение останется такое же, как было. Изменится только имя).Перенесутся только те файлы у которых в столбце B <>"".

07.11.2008, 18:49	#15
АLексаNдр Пользователь Регистрация: 11.08.2008 Сообщений: 17	Вот вырезка из кода Код: `...... DoEvents ce.Interior.Color = IIf(Dir(DestinationFolder & Filename) = "", vbRed, vbGreen) ' окраска ячеек End If` ..... В красный цвет не перекрашивается. Сделаные файлы становятся зелеными. А тех, которых не существует - остаются белыми.

09.11.2008, 05:10	#20
ZORRO2005 Форумчанин Регистрация: 26.11.2006 Сообщений: 584	АLексаNдр, EducatedFool, извиняюсь, что не создал новую тему,но продолжая эту тему, будет легче понять, что я хочу EducatedFool , можно ли сделать следующее? … В SourceFolder лежат файлы, которые мне надо переименовать и положить в DestinationFolder. В столбце A будет список файлов из SourceFolder без расширения (могут быть как jpeg ,bmp так и xls,xlsx…). В столбце B будут соответственно их новые названия без расширения (расширение останется такое же, как было. Изменится только имя).Перенесутся только те файлы у которых в столбце B <>"". Последний раз редактировалось ZORRO2005; 09.11.2008 в 05:20.

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Названия столбцов стали цифрами.	Flake	Microsoft Office Excel	2	06.09.2008 16:42
Печать pdf файлов из списка файлов в Excel	АПС	Microsoft Office Excel	5	15.04.2008 16:04
Макрос в Excel для обработки группы файлов	ad_sum	Microsoft Office Excel	1	29.12.2007 16:56
Вывод похожего названия в DBEdit	Wiser87	БД в Delphi	2	06.06.2007 11:42

07.11.2008, 21:09	#19
АLексаNдр Пользователь Регистрация: 11.08.2008 Сообщений: 17	Супер. получилось. Т.е. название ячейки справа от имени это и есть название папки? Супер. Спасибо. Теперь у жены уйдет меньше времени на работу, но больше на меня... Вы даже не представляете как помогли. Спасибо. P.S. Если что, то я еще постучусь? Ок?